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

2011-09-11 13:00 UTC+0200 Viktor Szakats (harbour.01 syenar.hu)

Browse Source 
* contrib/hbformat/hbfmtcls.prg
    ! fixed casing of some function names.

  * utils/hbmk2/hbmk2.prg
    ; all changes below apply to .xhp (xMate) to .hbp conversion:
    ! properly convert input filenames with spaces in them
    ! remove lib prefix from .a input filenames
    % do not add empty -L options
    * do not add include paths with %HB_INSTALL%\ in them
    + split non-portable, Borland-specific include path lists 
      concatenated with ';' into distinct -I options
    % do not add empty include paths

  * tests/testop.prg
  * tests/testntx.prg
  * tests/vmasort.prg
  * tests/testlbl.prg
  * tests/testidle.prg
  * tests/videotst.prg
  * tests/testmem.prg
  * tests/testinit.prg
  * tests/testhtml.prg
  * tests/tstcolor.prg
  * tests/vidtest.prg
  * tests/tstuse.prg
  * tests/vec1.prg
  * tests/while.prg
  * tests/tstdspac.prg
  * tests/version.prg
  * tests/testpre.prg
  * tests/tstprag.prg
    * formatted. mostly with hbformat.
This commit is contained in:
Viktor Szakats
2011-09-11 11:02:02 +00:00
parent 2e49f35f34
commit 10aaae71c2
21 changed files with 593 additions and 508 deletions
Download Patch File Download Diff File Expand all files Collapse all files

34
harbour/ChangeLog
View File

@@ -16,6 +16,40 @@
The license applies to all entries newer than 2009-04-28.
*/
2011-09-11 13:00 UTC+0200 Viktor Szakats (harbour.01 syenar.hu)
* contrib/hbformat/hbfmtcls.prg
! fixed casing of some function names.
* utils/hbmk2/hbmk2.prg
; all changes below apply to .xhp (xMate) to .hbp conversion:
! properly convert input filenames with spaces in them
! remove lib prefix from .a input filenames
% do not add empty -L options
* do not add include paths with %HB_INSTALL%\ in them
+ split non-portable, Borland-specific include path lists
concatenated with ';' into distinct -I options
% do not add empty include paths
* tests/testop.prg
* tests/testntx.prg
* tests/vmasort.prg
* tests/testlbl.prg
* tests/testidle.prg
* tests/videotst.prg
* tests/testmem.prg
* tests/testinit.prg
* tests/testhtml.prg
* tests/tstcolor.prg
* tests/vidtest.prg
* tests/tstuse.prg
* tests/vec1.prg
* tests/while.prg
* tests/tstdspac.prg
* tests/version.prg
* tests/testpre.prg
* tests/tstprag.prg
* formatted. mostly with hbformat.
2011-09-08 22:00 UTC+0200 Przemyslaw Czerpak (druzus/at/priv.onet.pl)
* harbour/src/rtl/gtxwc/gtxwc.h
* harbour/src/rtl/gtxwc/gtxwc.c

2
harbour/contrib/hbformat/hbfmtcls.prg
View File

@@ -181,7 +181,7 @@ METHOD New( aParams, cIniName ) CLASS HBFORMATCODE
"Array,Asc,AScan,ASize,ASort,At,Bin2I,Bin2L,Bin2W,Bof,Browse,CDow,Chr,CMonth,Col,CToD,CurDir," +;
"Date,Day,dbAppend,dbClearFil,dbClearInd,dbCloseAll,dbCloseArea,dbCommit,dbCreate,dbDelete,dbEdit,dbEval,Dbf,dbFilter,dbGoBottom,dbGoto,dbRecall,dbReindex,dbRelation,dbRLock,dbRSelect,dbRunLock," +;
"dbSeek,dbSelectArea,dbSetDriver,dbSetFilter,dbSetIndex,dbSetOrder,dbSetRelat,dbSkip,dbStruct,dbUnlock,dbUseArea,Deleted,Descend,DevOut,DevPos," +;
"Directory,DiskSpace,DispBegin,DispBox,DispCount,DispEnd,DispOut,DosError,Dow,Dtoc,Dtos,Empty,Eof,ErrorBlock,ErrorLevel,Eval,Exp,FClose,FCount,FCreate,FErase,FError,FieldBlock,FieldGet,FieldName," +;
"Directory,DiskSpace,DispBegin,DispBox,DispCount,DispEnd,DispOut,DosError,Dow,DToC,DToS,Empty,Eof,ErrorBlock,ErrorLevel,Eval,Exp,FClose,FCount,FCreate,FErase,FError,FieldBlock,FieldGet,FieldName," +;
"FieldPos,FieldPut,FieldWBlock,File,FkLabel,FkMax,FLock,FOpen,Found,FRead,FReadStr,FRename,FSeek,FWrite,GetEnv,HardCR,Header,iif,IndexExt,IndexKey,IndexOrd,Inkey,Int,IsAlpha,ISARRAY,ISCHARACTER," +;
"ISDATE,IsDigit,ISLOGICAL,IsLower,ISNUMBER,IsPrinter,IsUpper,I2Bin,L2Bin,LastKey,LastRec,Left,Len,Lower,LTrim,LUpdate,MakeDir,Max,MaxCol,MaxRow,MCol,MemoEdit,MemoLine,MemoRead," +;
"Memory,MemoTran,MemoWrite,MemVarBlock,Min,MLCount,MLCToPos,MLPos,Mod,Month,MPosToLC,NetErr,NetName,NextKey,NoSnow,OS,OrdBagExt,OrdBagName,OrdCreate,OrdDestroy,OrdFor,OrdKey,OrdListAdd," +;

6
harbour/tests/testhtml.prg
View File

@@ -1,6 +1,6 @@
//
// $Id$
//
/*
* $Id$
*/
/*
*

10
harbour/tests/testidle.prg
View File

@@ -8,19 +8,19 @@ PROCEDURE MAIN()
CLS
? "DEFAULT IDLEREPEAT =", SET( _SET_IDLEREPEAT )
? "DEFAULT IDLEREPEAT =", Set( _SET_IDLEREPEAT )
?
? "Idle Block should be displayed multiple times until key or 10 seconds elapsed!"
? "Press any key to begin..."
?
Inkey(0)
Inkey( 0 )
HB_IDLEADD( {|| QOut( "Idle Block" ) } )
hb_idleAdd( {|| QOut( "Idle Block" ) } )
Inkey( 2 )
SET( _SET_IDLEREPEAT, .F. )
HB_IDLEADD( {|| QOut( "Idle Block2" ) } )
hb_idleAdd( {|| QOut( "Idle Block2" ) } )
CLS
? "Idle Block & Block-2 should display ONCE! while waitning for key or 10 seconds elapsed!"
@@ -33,4 +33,4 @@ PROCEDURE MAIN()
Inkey( 2 )
?
RETURN
RETURN

8
harbour/tests/testinit.prg
View File

@@ -4,12 +4,12 @@
INIT PROCEDURE Init()
? "In Init"
? "In Init"
RETURN
RETURN
PROCEDURE MAIN()
PROCEDURE Main()
? "Should NEVER see this message!!!"
RETURN
RETURN

12
harbour/tests/testlbl.prg
View File

@@ -2,12 +2,12 @@
* $Id$
*/
FUNCTION MAIN()
USE test New
PROCEDURE Main()
LABEL FORM test
USE test NEW
USE
LABEL FORM test
RETURN NIL
USE
RETURN

16
harbour/tests/testmem.prg
View File

@@ -1,14 +1,14 @@
//
// $Id$
//
/*
* $Id$
*/
// Testing memory release
function main()
local a, b
PROCEDURE main()
a := "Hello"
b := 2
LOCAL a, b
return nil
a := "Hello"
b := 2
RETURN

101
harbour/tests/testntx.prg
View File

@@ -2,72 +2,73 @@
* $Id$
*/
function main
Local i:=0, block
Field Last, First
PROCEDURE Main()
Use test
Index On Left( Last,8 )+Left( First,8 ) To test1
Index On Left( Last,8 ) To test2
Index On Last To test3
Set Index To test1, test2, test3
set order to 1
? indexkey()
inkey(0)
Go Top
Do While !Eof()
LOCAL i := 0, block
FIELD Last, First
USE test
INDEX ON Left( Last, 8 ) + Left( First, 8 ) TO test1
INDEX ON Left( Last, 8 ) TO test2
INDEX ON Last TO test3
SET INDEX TO test1, test2, test3
SET ORDER TO 1
? IndexKey()
Inkey( 0 )
GO TOP
DO WHILE !Eof()
? ++i, Last, First
skip
Enddo
SKIP
ENDDO
? "------------"
inkey(0)
skip -1
Inkey( 0 )
SKIP -1
Do While !Bof()
? i--, Last, First
skip -1
Enddo
DO WHILE !Bof()
? i-- , Last, First
SKIP -1
ENDDO
i := 0
set order to 2
? indexkey()
inkey(0)
Go Top
Do While !Eof()
SET ORDER TO 2
? IndexKey()
Inkey( 0 )
GO TOP
DO WHILE !Eof()
? ++i, Last, First
skip
Enddo
SKIP
ENDDO
? "------------"
inkey(0)
skip -1
Inkey( 0 )
SKIP -1
Do While !Bof()
? i--, Last, First
skip -1
Enddo
DO WHILE !Bof()
? i-- , Last, First
SKIP -1
ENDDO
i := 0
set order to 3
? indexkey()
inkey(0)
Go Top
Do While !Eof()
SET ORDER TO 3
? IndexKey()
Inkey( 0 )
GO TOP
DO WHILE !Eof()
? ++i, Last, First
skip
Enddo
SKIP
ENDDO
? "------------"
inkey(0)
skip -1
Inkey( 0 )
SKIP -1
Do While !Bof()
? i--, Last, First
skip -1
Enddo
DO WHILE !Bof()
? i-- , Last, First
SKIP -1
ENDDO
Use
USE
return Nil
RETURN

46
harbour/tests/testop.prg
View File

@@ -59,26 +59,26 @@
//----------------------------------------------------------------------------//
function Main()
PROCEDURE Main()
local oCar := TCar():New( "red", 2 )
local oPetrol
LOCAL oCar := TCar():New( "red", 2 )
LOCAL oPetrol
oCar = oCar + oPetrol
oCar := oCar + oPetrol
return nil
RETURN
//----------------------------------------------------------------------------//
CLASS TCar
CREATE CLASS TCar
DATA cColor
DATA nDoors
DATA oGas
VAR cColor
VAR nDoors
VAR oGas
METHOD New( cColor, nDoors ) CONSTRUCTOR
METHOD Sum( oObject ) OPERATOR '+'
METHOD SUM( oObject ) OPERATOR '+'
ENDCLASS
@@ -86,25 +86,25 @@ ENDCLASS
METHOD New( cColor, nDoors ) CLASS TCar
if cColor == nil
cColor = "White"
endif
if nDoors == nil
nDoors = 4
endif
IF cColor == NIL
cColor := "White"
ENDIF
IF nDoors == NIL
nDoors := 4
ENDIF
::cColor = cColor
::nDoors = nDoors
::cColor := cColor
::nDoors := nDoors
return Self
RETURN Self
//----------------------------------------------------------------------------//
METHOD Sum( oObject ) CLASS TCar
METHOD SUM( oObject ) CLASS TCar
Alert( "+ has a special meaning and " + ;
"functionality for TCar Class objects!!!" )
"functionality for TCar Class objects!!!" )
return nil
RETURN NIL
//----------------------------------------------------------------------------//
//----------------------------------------------------------------------------//

62
harbour/tests/testpre.prg
View File

@@ -9,44 +9,44 @@ FUNCTION Main()
CLS
qOut( "Testing Harbour run-time preprocessing" )
qOut( "======================================" )
qOut( "" )
QOut( "Testing Harbour run-time preprocessing" )
QOut( "======================================" )
QOut( "" )
cString := "@ 10, 10 SAY 'Hello!'"
qOut( cString )
qOut( __Preprocess( cString ) )
qOut( "" )
QOut( cString )
QOut( __Preprocess( cString ) )
QOut( "" )
cString := "? 'Hello mom'"
qOut( cString )
qOut( __Preprocess( cString ) )
qOut( "" )
QOut( cString )
QOut( __Preprocess( cString ) )
QOut( "" )
cString := 'SET RELATION TO Something INTO MySelf'
qOut( cString )
qOut( __Preprocess( cString ) )
qOut( "" )
QOut( cString )
QOut( __Preprocess( cString ) )
QOut( "" )
cString := 'SET RELATION ADDITIVE TO Something INTO YourSelf'
qOut( cString )
qOut( __Preprocess( cString ) )
qOut( "" )
QOut( cString )
QOut( __Preprocess( cString ) )
QOut( "" )
cString := "#xcommand DEFAULT <v1> := <x1> => IF <v1> == NIL ; <v1> := <x1> ; END"
qOut( cString )
QOut( cString )
IF __ppAddRule( cString )
qOut( "Rule added successfully !" )
QOut( "Rule added successfully !" )
ELSE
qOut( "Rule addition failed ..." )
QOut( "Rule addition failed ..." )
ENDIF
cString := 'DEFAULT x := 100'
qOut( cString )
qOut( __Preprocess( cString ) )
qOut( "" )
QOut( cString )
QOut( __Preprocess( cString ) )
QOut( "" )
qOut( "Press <Enter>..." )
QOut( "Press <Enter>..." )
__Accept( "" )
CLS
@@ -62,22 +62,22 @@ FUNCTION Main()
'CLOSE ALL' }
FOR j := 1 TO 2
qOut( iif( j = 1, "Before", "After" ) + " __Preprocess()" )
qOut( "===================" )
qOut( "" )
FOR i := 1 TO len( aScript )
QOut( iif( j = 1, "Before", "After" ) + " __Preprocess()" )
QOut( "===================" )
QOut( "" )
FOR i := 1 TO Len( aScript )
? iif( j = 1, aScript[i], __Preprocess( aScript[i] ) )
? iif( j = 1, aScript[ i ], __Preprocess( aScript[ i ] ) )
NEXT
qOut( "" )
qOut( "Press <Enter> key..." )
QOut( "" )
QOut( "Press <Enter> key..." )
__Accept( "" )
CLS
NEXT
RETURN NIL
Exit PROCEDURE ExitTest
EXIT PROCEDURE ExitTest()
__PP_Free()
Return
RETURN

29
harbour/tests/tstcolor.prg
View File

@@ -1,9 +1,7 @@
//
// $Id$
//
/*
* $Id$
*/
//
// tstColor
//
// This program demonstrates that setColor() works with
// Set( _SET_COLOR ) and also that the internal representation
@@ -21,31 +19,32 @@
#include "color.ch"
#include "set.ch"
proc main
Local cColor := "r+/bg*,rg*/ng+,w/n,b+/w,rg/b,w+/n*"
PROCEDURE Main()
? "original set ", set(_SET_COLOR )
? "should match ", setColor( cColor )
LOCAL cColor := "r+/bg*,rg*/ng+,w/n,b+/w,rg/b,w+/n*"
? "original set ", Set( _SET_COLOR )
? "should match ", SetColor( cColor )
? "input 1 ", cColor
? "return ", setColor("1/7,9/15")
? "return ", SetColor( "1/7,9/15" )
? "input 2 ", "1/7,9/15"
? "return ", setColor()
? "final set ", set(_SET_COLOR )
? "return ", SetColor()
? "final set ", Set( _SET_COLOR )
SetColor("BG/N, N/BG")
SetColor( "BG/N, N/BG" )
? "Hello1"
ColorSelect( CLR_ENHANCED )
? "Hello2"
ColorSelect( CLR_STANDARD )
? "Hello3"
ColorSelect( CLR_ENHANCED )
SetColor("GR/N, N/GR")
SetColor( "GR/N, N/GR" )
? "Hello4"
ColorSelect( CLR_ENHANCED )
? "Hello5"
ColorSelect( CLR_STANDARD )
? "Hello6"
SetColor("B/N, N/B")
SetColor( "B/N, N/B" )
? "Hello7"
RETURN

46
harbour/tests/tstdspac.prg
View File

@@ -1,37 +1,37 @@
/*
* $Id$
*/
$Id$
/*
This program demonstrates that the 4 diskspace related functions work
correctly for disks of any size.
tstdspac
Certain os's may allow limits to the amount of disk space available to
a user. If that is the case, you should see a difference between
the return value of DiskSpace() and DiskFree().
This program demonstrates that the 4 diskspace related functions work
correctly for disks of any size.
Currently, Disk quota's are only implimented for NT.
Certain os's may allow limits to the amount of disk space available to
a user. If that is the case, you should see a difference between
the return value of DiskSpace() and DiskFree().
NOTE: Unlike Clipper, these functions return a floating point number!
Currently, Disk quota's are only implimented for NT.
Written by Paul Tucker {ptucker@sympatico.ca>
www - http://harbour-project.org
NOTE: Unlike Clipper, these functions return a floating point number!
Written by Paul Tucker {ptucker@sympatico.ca>
www - http://harbour-project.org
This test program placed in the public domain
This test program placed in the public domain
*/
#include "fileio.ch"
proc main( cDisk )
if empty( cDisk )
PROCEDURE Main( cDisk )
IF Empty( cDisk )
cDisk := "0"
Endif
cDisk := Val( cDisk )
ENDIF
cDisk := Val( cDisk )
? "Bytes available on disk: " + Transform( diskspace(cDisk, HB_DISK_FREE ),"999,999,999,999")
? "Bytes available for use: " + Transform( diskspace(cDisk, HB_DISK_AVAIL ),"999,999,999,999")
? " Bytes used: " + Transform( diskspace(cDisk, HB_DISK_USED ),"999,999,999,999")
? " Total bytes on disk "+PadL(cDisk,2)+": " + Transform( diskspace(cDisk, HB_DISK_TOTAL ),"999,999,999,999")
? "Bytes available on disk: " + Transform( DiskSpace( cDisk, HB_DISK_FREE ), "999,999,999,999" )
? "Bytes available for use: " + Transform( DiskSpace( cDisk, HB_DISK_AVAIL ), "999,999,999,999" )
? " Bytes used: " + Transform( DiskSpace( cDisk, HB_DISK_USED ), "999,999,999,999" )
? " Total bytes on disk " + PadL( cDisk, 2 ) + ": " + Transform( DiskSpace( cDisk, HB_DISK_TOTAL ), "999,999,999,999" )
return
RETURN

28
harbour/tests/tstprag.prg
View File

@@ -6,31 +6,39 @@
#pragma TracePragmas=On
#pragma ExitSeverity=1
/* Unknow pragmas will be ignored silently */
/* Unknown pragmas will be ignored silently */
#pragma BadPragma=off
#pragma /Y+
function Main()
FUNCTION Main()
#pragma Shortcut=On
#pragma Shortcut= Off
#pragma Shortcut = On
#pragma Shortcut(OFF)
#pragma Shortcut( On)
#pragma Shortcut( OFF )
#pragma Shortcut( On )
#pragma Shortcut( OFF )
#pragma Shortcut( ON
/* or #pragma /Z+ */
/* or #pragma /Z+ */
if .t. .and. .f.
? "Always"
endif
IF .T. .AND. .F.
? "Always"
ENDIF
if .f. .and. .t.
? "Never"
endif
IF .F. .AND. .T.
? "Never"
ENDIF
#pragma /Z-
/* or #pragma Shortcut=Off */
@@ -46,4 +54,4 @@ function Main()
/* Pragmas with bad values will cause an error */
#pragma WarningLevel=8
return nil
RETURN NIL

76
harbour/tests/tstuse.prg
View File

@@ -2,47 +2,53 @@
* $Id$
*/
#define EOL chr(13)+chr(10)
#command ? [<x,...>] => outstd(EOL)[;outstd(<x>)]
proc main()
? OS(), VERSION()
if !file("_tst.dbf")
dbCreate("_tst",{{"F1","C",1,0}})
endif
if !file("_tst2.dbf")
dbCreate("_tst2",{{"F1","C",1,0}})
endif
#define EOL Chr( 13 ) + Chr( 10 )
#command ? [<x,...>] => OutStd( EOL )[;OutStd( <x> )]
PROCEDURE Main()
? OS(), Version()
IF ! hb_FileExists( "_tst.dbf" )
dbCreate( "_tst", { { "F1","C",1,0 } } )
ENDIF
IF ! hb_FileExists( "_tst2.dbf" )
dbCreate( "_tst2", { { "F1","C",1,0 } } )
ENDIF
USE _tst NEW ALIAS "ONE" EXCLUSIVE
? select(), alias(), netErr(), used()
? Select(), Alias(), NetErr(), Used()
?
mkTest( .T., "NORDD",, "TWO", .T., .F. )
mkTest( .T., "DBF",, "TWO", .T., .F. )
mkTest( .T., "DBF", "", "TWO", .T., .F. )
mkTest( .T., "DBF", "nofile", "TWO", .T., .F. )
mkTest( .T., "DBF", "_tst2", "ONE", .T., .F. )
mkTest( .T., "DBF", "_tst", "ONE", .T., .F. )
mkTest( .T., "DBF", "_tst", "TWO", .T., .F. )
mkTest( .T. , "NORDD", , "TWO", .T. , .F. )
mkTest( .T. , "DBF", , "TWO", .T. , .F. )
mkTest( .T. , "DBF", "", "TWO", .T. , .F. )
mkTest( .T. , "DBF", "nofile", "TWO", .T. , .F. )
mkTest( .T. , "DBF", "_tst2", "ONE", .T. , .F. )
mkTest( .T. , "DBF", "_tst", "ONE", .T. , .F. )
mkTest( .T. , "DBF", "_tst", "TWO", .T. , .F. )
?
dbUseArea( .T., "DBF", "_tst", "ONE", .T., .F. )
? select(), alias(), netErr(), used()
dbUseArea( .T., "DBF", "_tst", "TWO", .T., .F. )
? select(), alias(), netErr(), used()
dbUseArea( .T. , "DBF", "_tst", "ONE", .T. , .F. )
? Select(), Alias(), NetErr(), Used()
dbUseArea( .T. , "DBF", "_tst", "TWO", .T. , .F. )
? Select(), Alias(), NetErr(), Used()
?
dbSelectArea( 1 )
mkTest( .F., "NORDD",, "TWO", .T., .F. )
mkTest( .F. , "NORDD", , "TWO", .T. , .F. )
?
return
proc mkTest( lNewArea, cRdd, cFile, cAlias, lShared, lReadOnly )
local cbErr:=errorBlock({|oErr|break(oErr)}), oErr
netErr(.f.)
begin sequence
dbUseArea( lNewArea, cRdd, cFile, cAlias, lShared, lReadOnly )
recover using oErr
? "Error:", oErr:subCode, oErr:description, oErr:operation, oErr:osCode
end
? select(), alias(), netErr(), used()
errorBlock(cbErr)
return
RETURN
PROCEDURE mkTest( lNewArea, cRdd, cFile, cAlias, lShared, lReadOnly )
LOCAL cbErr := ErrorBlock( { |oErr|break( oErr ) } ), oErr
NetErr( .F. )
BEGIN SEQUENCE
dbUseArea( lNewArea, cRdd, cFile, cAlias, lShared, lReadOnly )
RECOVER USING oErr
? "Error:", oErr:subCode, oErr:description, oErr:operation, oErr:osCode
END
? Select(), Alias(), NetErr(), Used()
ErrorBlock( cbErr )
RETURN

10
harbour/tests/vec1.prg
View File

@@ -1,10 +1,10 @@
//NOTEST
//
// $Id$
//
/*
* $Id$
*/
// ; Donated to the public domain by
// Viktor Szakats (harbour.01 syenar.hu)
/* Donated to the public domain by
Viktor Szakats (harbour.01 syenar.hu) */
FUNCTION Main()

7
harbour/tests/version.prg
View File

@@ -3,6 +3,7 @@
*/
/* Testing the VERSION function */
/* Harbour Project source code
http://harbour-project.org/
Donated to the public domain by David G. Holm <dholm@jsd-llc.com>.
@@ -10,8 +11,8 @@
PROCEDURE Main()
outstd( chr( 34 ) + version() + chr( 34 ) + hb_eol() )
outstd( chr( 34 ) + hb_compiler() + chr( 34 ) + hb_eol() )
outstd( chr( 34 ) + os() + chr( 34 ) + hb_eol() )
OutStd( Chr( 34 ) + Version() + Chr( 34 ) + hb_eol() )
OutStd( Chr( 34 ) + hb_compiler() + Chr( 34 ) + hb_eol() )
OutStd( Chr( 34 ) + OS() + Chr( 34 ) + hb_eol() )
RETURN

117
harbour/tests/videotst.prg
View File

@@ -2,12 +2,9 @@
* $Id$
*/
* videotst.prg
*
* Copyright 2000 Alejandro de Garate <alex_degarate@hotmail.com>
*
* Test SETMODE() for Harbour Project
*
// Copyright 2000 Alejandro de Garate <alex_degarate@hotmail.com>
//
// Test SETMODE() for Harbour Project
#define HB_NOT_SUPPORTED "Video mode not supported on this system.."
#define HB_VROW 1
@@ -16,70 +13,72 @@
FUNCTION MAIN()
LOCAL nMode:= 1, nRow, lSuccess
LOCAL aVModes:= {;
{ 12, 40, " 12 x 40 " },;
{ 25, 40, " 25 x 40 " },;
{ 28, 40, " 28 x 40 " },;
{ 50, 40, " 50 x 40 " },;
{ 12, 80, " 12 x 80 " },;
{ 25, 80, " 25 x 80 " },;
{ 28, 80, " 28 x 80 " },;
{ 43, 80, " 43 x 80 " },;
{ 50, 80, " 50 x 80 " },;
{ 60, 80, " 60 x 80 " } }
LOCAL nMode := 1, nRow, lSuccess
LOCAL aVModes := { ;
{ 12, 40, " 12 x 40 " }, ;
{ 25, 40, " 25 x 40 " }, ;
{ 28, 40, " 28 x 40 " }, ;
{ 50, 40, " 50 x 40 " }, ;
{ 12, 80, " 12 x 80 " }, ;
{ 25, 80, " 25 x 80 " }, ;
{ 28, 80, " 28 x 80 " }, ;
{ 43, 80, " 43 x 80 " }, ;
{ 50, 80, " 50 x 80 " }, ;
{ 60, 80, " 60 x 80 " } }
DO WHILE (nMode != 0)
DO WHILE nMode != 0
CLEAR SCREEN
@ 0, 0 SAY "Select the video mode you want to test.."
CLEAR SCREEN
@ 0, 0 SAY "Select the video mode you want to test.."
FOR nRow:= 1 To 5
@ 2 + nRow, 10 PROMPT aVModes [nRow] [HB_PROMPT]
NEXT
FOR nRow := 1 TO 5
@ 2 + nRow, 10 PROMPT aVModes[ nRow ][ HB_PROMPT ]
NEXT
FOR nRow:= 6 To 10
@ 2 + nRow - 5, 25 PROMPT aVModes [nRow] [HB_PROMPT]
NEXT
MENU TO nMode
FOR nRow := 6 TO 10
@ 2 + nRow - 5, 25 PROMPT aVModes[ nRow ][ HB_PROMPT ]
NEXT
MENU TO nMode
If (nMode > 0)
lSuccess := SETMODE( aVModes [nMode] [HB_VROW], aVModes [nMode] [HB_VCOL])
IF nMode > 0
lSuccess := SetMode( aVModes[ nMode ][ HB_VROW ], aVModes[ nMode ][ HB_VCOL ] )
IF lSuccess == .T.
TESTBOX( aVModes [nMode] [HB_PROMPT] )
ELSE
@ MAXROW(), 0 SAY HB_NOT_SUPPORTED
INKEY(0)
ENDIF
ENDIF
IF lSuccess == .T.
TESTBOX( aVModes[ nMode ][ HB_PROMPT ] )
ELSE
@ MaxRow(), 0 SAY HB_NOT_SUPPORTED
Inkey( 0 )
ENDIF
ENDIF
ENDDO
ENDDO
QUIT
QUIT
RETURN 0
RETURN 0
//*************************
**************************
PROCEDURE TESTBOX( cMode )
****************************************************************************
* Simple testing screen..
****************************************************************************
LOCAL nRow
CLEAR SCREEN
@ 0, 0 TO MAXROW(), MAXCOL() DOUBLE
@ 0, 3 SAY cMode
@ MAXROW(), 3 SAY " Press a key "
PROCEDURE TESTBOX( cMode )
@ 8, 0 SAY REPLICATE( " ", 20)
@ 9, 0 SAY REPLICATE( "0123456789", 20)
//***************************************************************************
// Simple testing screen..
//***************************************************************************
LOCAL nRow
CLEAR SCREEN
@ 0, 0 TO MaxRow(), MaxCol() DOUBLE
@ 0, 3 SAY cMode
@ MaxRow(), 3 SAY " Press a key "
FOR nRow:= 0 TO MAXROW()
@ nRow, 18 SAY STR( nRow, 2)
NEXT
@ 8, 0 SAY Replicate( " ", 20 )
@ 9, 0 SAY Replicate( "0123456789", 20 )
@ 4, 2 SAY "MaxRow() = " + STR( MAXROW(), 3)
@ 5, 2 SAY "MaxCol() = " + STR( MAXCOL(), 3)
INKEY(0)
RETURN
FOR nRow := 0 TO MaxRow()
@ nRow, 18 SAY Str( nRow, 2 )
NEXT
@ 4, 2 SAY "MaxRow() = " + Str( MaxRow(), 3 )
@ 5, 2 SAY "MaxCol() = " + Str( MaxCol(), 3 )
Inkey( 0 )
RETURN

304
harbour/tests/vidtest.prg
View File

@@ -1,6 +1,7 @@
/*
* $Id$
*/
/*
* Harbour project video test code
*
@@ -8,212 +9,225 @@
*
* Redirect the output of this program to a file.
*
* ie: VidTest >results
* ie: vidtest > results
*
*/
#include "box.ch"
#ifndef __CLIP__
#ifdef FlagShip
#xtranslate hb_secondsCPU([<x>]) => secondsCPU([<x>])
#else
#ifndef __HARBOUR__
#xtranslate hb_secondsCPU([<x>]) => seconds([<x>])
#endif
#define EOL chr(13) + chr(10)
#endif
#ifdef FlagShip
#xtranslate hb_secondsCPU( [<x>] ) => secondsCPU( [<x>] )
#else
#ifndef __HARBOUR__
#xtranslate hb_secondsCPU( [<x>] ) => Seconds( [<x>] )
#endif
#define EOL Chr( 13 ) + Chr( 10 )
#endif
#endif
#ifndef EOL
#define EOL chr(10)
#define EOL Chr( 10 )
#endif
#command ? => outstd(EOL);outerr(EOL)
#command ? <xx,...> => outstd(<xx>, EOL);outerr(<xx>, EOL)
#ifdef FlagShip
static nDispCount := 0
#xtranslate dispbegin() => iif((++nDispCount)==1, dispbegin(NIL),)
#xtranslate dispend() => iif(nDispCount>0 .and. (--nDispCount)==0, dispend(NIL),)
STATIC nDispCount := 0
#xtranslate dispbegin() => iif( ( ++nDispCount ) == 1, DispBegin( NIL ), )
#xtranslate dispend() => iif( nDispCount > 0 .AND. ( --nDispCount ) == 0, DispEnd( NIL ), )
#endif
function main()
local aResult := {}
FUNCTION Main()
Initialise() // Initialise Screen Display
LOCAL aResult := {}
// Perform Tests
aadd(aResult, StaticText() )
aadd(aResult, WindowBounce() )
aadd(aResult, ColourBoxes() )
Initialise() // Initialise Screen Display
// Display Results
Summary(aResult)
return NIL
// Perform Tests
AAdd( aResult, StaticText() )
AAdd( aResult, WindowBounce() )
AAdd( aResult, ColourBoxes() )
// Display Results
Summary( aResult )
RETURN NIL
// initialise the screen
static function Initialise()
//SetMode(25,80)
set colour to "W+/BG"
dispbox(0,0,MaxRow(), MaxCol(), replicate(chr(176),9), "BG/B")
return NIL
STATIC FUNCTION Initialise()
// SetMode( 25, 80 )
SET colour TO "W+/BG"
DispBox( 0, 0, MaxRow(), MaxCol(), Replicate( Chr(176 ),9 ), "BG/B" )
RETURN NIL
// repeatedly display a string in the same position
// this test determines how well the Screen i/o subsystem is
// caching screen writes.
static function StaticText()
local cResult
local r := MaxRow() / 2
local str := Version()
local c
local i := 0
local nEnd := 0
local nStart := hb_secondsCPU()
str := "Hello World - From " + Left(str,At(" ",str)-1)
c := (MaxCol()-len(str)) / 2
STATIC FUNCTION StaticText()
for i := 1 to 5000
@ r, c say str
next i
LOCAL cResult
LOCAL r := MaxRow() / 2
LOCAL str := Version()
LOCAL c
LOCAL i
LOCAL nEnd
LOCAL nStart := hb_secondsCPU()
nEnd := hb_secondsCPU()
str := "Hello World - From " + Left( str, At( " ", str ) - 1 )
c := ( MaxCol() - Len( str ) ) / 2
cResult := "StaticText: Iterations=5000, Time="+alltrim(str(nEnd-nStart))+ ;
"secs, Average FPS = "+alltrim(str(round(5000 / (nEnd-nStart),0)))+" FPS"
return cResult
FOR i := 1 TO 5000
@ r, c SAY str
NEXT
nEnd := hb_secondsCPU()
cResult := "StaticText: Iterations=5000, Time=" + hb_ntos( nEnd - nStart ) + ;
"secs, Average FPS = " + hb_ntos( Round( 5000 / ( nEnd - nStart ), 0 ) ) + " FPS"
RETURN cResult
// Bounce a window around the screen a few thousand times
// timing the duration, and determining the average FPS
static function WindowBounce()
local cResult := ""
local nBoxes := Min(MaxRow(), MaxCol()-7)-6 /* keep the box in bounds */
local x := array(NBOXES)
local y := array(NBOXES)
local dx := array(NBOXES)
local dy := array(NBOXES)
local clr := array(NBOXES)
local scr := array(NBOXES)
local nFrames := 0
local nStart := 0
local nEnd := 0
local i := 0
local aCol := {"N", "B", "G", "BG", "R", "RB", "GR", "W", ;
"N*","B*","G*","BG*","R*","RB*","GR*","W*" }
// initialise boxes
for i := 1 to nBoxes
x[i] := i
y[i] := i-1
dx[i] := -1
dy[i] := 1
clr[i] := "W+/"+aCol[(i-1)%16+1]
next i
STATIC FUNCTION WindowBounce()
nStart := hb_secondsCPU()
dispbegin()
LOCAL cResult
LOCAL nBoxes := Min( MaxRow(), MaxCol() - 7 ) - 6 /* keep the box in bounds */
LOCAL x := Array( NBOXES )
LOCAL y := Array( NBOXES )
LOCAL dx := Array( NBOXES )
LOCAL dy := Array( NBOXES )
LOCAL clr := Array( NBOXES )
LOCAL scr := Array( NBOXES )
LOCAL nFrames := 0
LOCAL nStart
LOCAL nEnd
LOCAL i
LOCAL aCol := { "N", "B", "G", "BG", "R", "RB", "GR", "W", ;
"N*", "B*", "G*", "BG*", "R*", "RB*", "GR*", "W*" }
do while nFrames < 5000
// initialise boxes
FOR i := 1 TO nBoxes
x[ i ] := i
y[ i ] := i - 1
dx[ i ] := -1
dy[ i ] := 1
clr[ i ] := "W+/" + aCol[ ( i - 1 ) % 16 + 1 ]
NEXT
for i := 1 to nBoxes
scr[i] := SaveScreen(x[i], y[i], x[i]+6, y[i]+12)
@ x[i], y[i], x[i]+6, y[i]+12 box B_SINGLE+" " color clr[i]
next i
nStart := hb_secondsCPU()
DispBegin()
dispend()
dispbegin()
DO WHILE nFrames < 5000
for i := nBoxes to 1 step -1
// remove boxes from screen
RestScreen(x[i], y[i], x[i]+6, y[i]+12, scr[i])
FOR i := 1 TO nBoxes
scr[ i ] := SaveScreen( x[ i ], y[ i ], x[ i ] + 6, y[ i ] + 12 )
@ x[ i ], y[ i ], x[ i ] + 6, y[ i ] + 12 BOX B_SINGLE + " " COLOR clr[ i ]
NEXT
// move
x[i] += dx[i]
y[i] += dy[i]
if x[i] <= 0 .or. x[i]+6 >= MaxRow()
dx[i] := -dx[i]
endif
if y[i] <= 0 .or. y[i]+12 >= MaxCol()
dy[i] := -dy[i]
endif
next i
DispEnd()
DispBegin()
++nFrames
enddo
FOR i := nBoxes TO 1 STEP -1
// remove boxes from screen
RestScreen( x[ i ], y[ i ], x[ i ] + 6, y[ i ] + 12, scr[ i ] )
dispend()
nEnd := hb_secondsCPU()
// move
x[ i ] += dx[ i ]
y[ i ] += dy[ i ]
IF x[ i ] <= 0 .OR. x[ i ] + 6 >= MaxRow()
dx[ i ] := - dx[ i ]
ENDIF
IF y[ i ] <= 0 .OR. y[ i ] + 12 >= MaxCol()
dy[ i ] := - dy[ i ]
ENDIF
next i
cResult := "WindowBounce:Iterations="+alltrim(str(nFrames))+", Time="+alltrim(str(nEnd-nStart))+ ;
"secs, Average FPS = "+alltrim(str(round(nFrames / (nEnd-nStart),0)))+" FPS"
++nFrames
ENDDO
return cResult
DispEnd()
nEnd := hb_secondsCPU()
cResult := "WindowBounce:Iterations=" + hb_ntos( nFrames ) + ", Time=" + hb_ntos( nEnd - nStart ) + ;
"secs, Average FPS = " + hb_ntos( Round( nFrames / ( nEnd - nStart ), 0 ) ) + " FPS"
RETURN cResult
// Display colour boxes, repeatedly, this will determine
// how efficiently the screen i/o subsystem is caching the
// dispbegin()'s and dispend()'s
static function ColourBoxes()
local cResult := ""
local nFrames := 0
local nStart := 0
local nEnd := 0
local i := 0
local nDir := 1
local nDepth := 0
local aCol := {"N", "B", "G", "BG", "R", "RB", "GR", "W", ;
"N*","B*","G*","BG*","R*","RB*","GR*","W*" }
nStart := hb_secondsCPU()
// display boxes to screen
STATIC FUNCTION ColourBoxes()
do while nFrames < 5000
if nDir == 1
dispbegin()
else
dispend()
endif
LOCAL cResult
LOCAL nFrames := 0
LOCAL nStart
LOCAL nEnd
LOCAL i
LOCAL nDir := 1
LOCAL nDepth := 0
LOCAL aCol := { "N", "B", "G", "BG", "R", "RB", "GR", "W", ;
"N*", "B*", "G*", "BG*", "R*", "RB*", "GR*", "W*" }
nDepth += nDir
nStart := hb_secondsCPU()
// display boxes to screen
if nDepth > 4 .or. nDepth < 1
nDir := -nDir
endif
i := nFrames %16 +1
dispbox(5,10, MaxRow()-5, MaxCol()-10, ;
replicate(chr(i+64),9),;
"W+/"+aCol[i] )
++nFrames
enddo
DO WHILE nFrames < 5000
IF nDir == 1
DispBegin()
ELSE
DispEnd()
ENDIF
// remove any nested dispbegins()
do while nDepth > 0
dispend()
nDepth--
enddo
nDepth += nDir
nEnd := hb_secondsCPU()
IF nDepth > 4 .OR. nDepth < 1
nDir := - nDir
ENDIF
i := nFrames % 16 + 1
DispBox( 5, 10, MaxRow() - 5, MaxCol() - 10, ;
Replicate( Chr( i + 64 ), 9 ), ;
"W+/" + aCol[ i ] )
++nFrames
ENDDO
cResult := "ColourBoxes: Iterations="+alltrim(str(nFrames))+", Time="+alltrim(str(nEnd-nStart))+ ;
"secs, Average FPS = "+alltrim(str(round(nFrames / (nEnd-nStart),0)))+" FPS"
// remove any nested dispbegins()
DO WHILE nDepth > 0
DispEnd()
nDepth--
ENDDO
return cResult
nEnd := hb_secondsCPU()
cResult := "ColourBoxes: Iterations=" + hb_ntos( nFrames ) + ", Time=" + hb_ntos( nEnd - nStart ) + ;
"secs, Average FPS = " + hb_ntos( Round( nFrames / ( nEnd - nStart ), 0 ) ) + " FPS"
RETURN cResult
// display results
static function Summary(aResult)
local i := 0
clear screen
? "Resolution: " + Ltrim(str( MaxRow()+1 )) + " x " + Ltrim(str( MaxCol()+1 )) + " " + Version()
for i := 1 to len(aResult)
? aResult[i]
next i
?
? "press any key to continue"
inkey(0)
STATIC FUNCTION Summary( aResult )
return aResult
LOCAL i
CLEAR SCREEN
? "Resolution: " + hb_ntos( MaxRow() + 1 ) + " x " + hb_ntos( MaxCol() + 1 ) + " " + Version()
FOR i := 1 TO Len( aResult )
? aResult[ i ]
NEXT
?
? "press any key to continue"
Inkey( 0 )
RETURN aResult

132
harbour/tests/vmasort.prg
View File

@@ -1,85 +1,85 @@
//
// $Id$
//
/*
* $Id$
*/
function Main( nPass )
PROCEDURE Main( nPass )
LOCAL aTest
LOCAL aOrig
LOCAL aTest
LOCAL aOrig
if nPass == NIL
nPass := 1
else
nPass := Val( nPass )
endif
IF nPass == NIL
nPass := 1
ELSE
nPass := Val( nPass )
ENDIF
? "Testing aSort with " + Str( nPass ) + " loops."
?
aTest := aMkArray( nPass )
aOrig := aClone( aTest )
? "Testing aSort with " + Str( nPass ) + " loops."
?
aTest := aMkArray( nPass )
aOrig := AClone( aTest )
set( _SET_DATEFORMAT, "mm/dd/yyyy" )
SET DATE ANSI
? "Original.....:", aDump( aOrig )
? "Asort.c......:", aDump( aSort( aTest ) )
// ? "Asort.c.block:", aDump( aSort( aTest, , , {| x, y | x < y } ) )
? "Original.....:", aDump( aOrig )
? "Asort.c......:", aDump( ASort( aTest ) )
// ? "Asort.c.block:", aDump( aSort( aTest, , , {| x, y | x < y } ) )
return nil
RETURN
static function aMkArray( nPass )
STATIC FUNCTION aMkArray( nPass )
LOCAL aData := {}
LOCAL n
LOCAL nMult := 200
LOCAL nMid := ( nMult / 2 ) + 1
LOCAL nMax := nPass * nMult
LOCAL aData := {}
LOCAL n
LOCAL nMult := 200
LOCAL nMid := ( nMult / 2 ) + 1
LOCAL nMax := nPass * nMult
for n := 1 to nMax
aAdd( aData, NIL )
aAdd( aData, nMid - n )
aAdd( aData, Date() - n )
aAdd( aData, iif( n % 2 == 0, .f., .t. ) )
aAdd( aData, Replicate( Chr( 64 + ( n % 256 ) ) , nPass ) )
aAdd( aData, {|| n } )
aAdd( aData, Array( n ) )
aAdd( aData, ErrorNew() )
next
FOR n := 1 TO nMax
AAdd( aData, NIL )
AAdd( aData, nMid - n )
AAdd( aData, Date() - n )
AAdd( aData, iif( n % 2 == 0, .F., .T. ) )
AAdd( aData, Replicate( Chr( 64 + ( n % 256 ) ), nPass ) )
AAdd( aData, {|| n } )
AAdd( aData, Array( n ) )
AAdd( aData, ErrorNew() )
NEXT
return aData
RETURN aData
function aDump( a )
FUNCTION aDump( a )
local cStr := ""
local n := len( a )
local i
LOCAL cStr := ""
LOCAL n := Len( a )
LOCAL i
for i := 1 to n
cStr += alltrim( xToStr( a[i] ) ) + " "
next
FOR i := 1 TO n
cStr += AllTrim( xToStr( a[ i ] ) ) + " "
NEXT
return cStr
RETURN cStr
function xToStr( xValue )
FUNCTION xToStr( xValue )
LOCAL cType := ValType( xValue )
LOCAL cType := ValType( xValue )
do case
case cType == "C" .or. cType == "M"
return xValue
case cType == "N"
return AllTrim( Str( xValue ) )
case cType == "D"
return DToC( xValue )
case cType == "L"
return iif( xValue, ".T.", ".F." )
case cType == "U"
return "NIL"
case cType == "A"
return "{.}"
case cType == "B"
return "{|| }"
case cType == "O"
return "[O]"
endcase
DO CASE
CASE cType == "C" .OR. cType == "M"
RETURN xValue
CASE cType == "N"
RETURN AllTrim( Str( xValue ) )
CASE cType == "D"
RETURN DToC( xValue )
CASE cType == "L"
RETURN iif( xValue, ".T.", ".F." )
CASE cType == "U"
RETURN "NIL"
CASE cType == "A"
RETURN "{.}"
CASE cType == "B"
RETURN "{|| }"
CASE cType == "O"
RETURN "[O]"
ENDCASE
return xValue
RETURN xValue

16
harbour/tests/while.prg
View File

@@ -1,15 +1,15 @@
//
// $Id$
//
/*
* $Id$
*/
// while loop test
function Main()
PROCEDURE Main()
local x := 0
LOCAL x := 0
while x++ < 1000
DO WHILE x++ < 1000
QOut( x )
end
ENDDO
return nil
RETURN

39
harbour/utils/hbmk2/hbmk2.prg
View File

@@ -11929,7 +11929,7 @@ STATIC PROCEDURE convert_xhp_to_hbp( hbmk, cSrcName, cDstName )
LOCAL cSrc := MemoRead( cSrcName )
LOCAL cDst
LOCAL aDst := {}
LOCAL tmp
LOCAL tmp, tmp1
LOCAL cLine
LOCAL cSetting
LOCAL cValue
@@ -11966,7 +11966,11 @@ STATIC PROCEDURE convert_xhp_to_hbp( hbmk, cSrcName, cDstName )
CASE ".c"
CASE ".prg"
IF !( "%HB_INSTALL%\" $ cFile )
AAdd( aDst, StrTran( cFile, "%HOME%\" ) )
tmp := StrTran( cFile, "%HOME%\" )
IF " " $ tmp
tmp := Chr( 34 ) + tmp + Chr( 34 )
ENDIF
AAdd( aDst, tmp )
ENDIF
EXIT
CASE ".lib"
@@ -11974,17 +11978,29 @@ STATIC PROCEDURE convert_xhp_to_hbp( hbmk, cSrcName, cDstName )
IF !( "%C_LIB_INSTALL%\" $ cFile ) .AND. ;
!( "%HB_LIB_INSTALL%\" $ cFile )
cFile := StrTran( cFile, "%HOME%\" )
IF !( hb_FNameDir( cFile ) $ hLIBPATH )
IF !( hb_FNameDir( cFile ) $ hLIBPATH ) .AND. ! Empty( hb_FNameDir( cFile ) )
hLIBPATH[ hb_FNameDir( cFile ) ] := NIL
ENDIF
AAdd( aDst, "-l" + hb_FNameName( cFile ) )
tmp := hb_FNameName( cFile )
IF hb_FNameExt( cFile ) == ".a" .AND. Left( tmp, 3 ) == "lib"
tmp := SubStr( tmp, 4 )
ENDIF
tmp := "-l" + tmp
IF " " $ tmp
tmp := Chr( 34 ) + tmp + Chr( 34 )
ENDIF
AAdd( aDst, tmp )
ENDIF
EXIT
CASE ".obj"
CASE ".o"
IF !( "%C_LIB_INSTALL%\" $ cFile ) .AND. ;
!( "%HB_LIB_INSTALL%\" $ cFile )
AAdd( aDst, StrTran( cFile, "%HOME%\" ) )
tmp := StrTran( cFile, "%HOME%\" )
IF " " $ tmp
tmp := Chr( 34 ) + tmp + Chr( 34 )
ENDIF
AAdd( aDst, tmp )
ENDIF
EXIT
ENDSWITCH
@@ -12009,10 +12025,17 @@ STATIC PROCEDURE convert_xhp_to_hbp( hbmk, cSrcName, cDstName )
EXIT
CASE "Include"
FOR EACH tmp IN aValue
IF Left( tmp, 2 ) == "-I"
tmp := SubStr( tmp, 3 )
IF !( "%HB_INSTALL%\" $ tmp )
IF Left( tmp, 2 ) == "-I"
tmp := SubStr( tmp, 3 )
ENDIF
tmp := StrTran( StrTran( tmp, '"' ), "%HOME%\" )
FOR EACH tmp1 IN hb_ATokens( tmp, ";" )
IF ! Empty( tmp1 )
AAdd( aDst, "-incpath=" + tmp1 )
ENDIF
NEXT
ENDIF
AAdd( aDst, "-incpath=" + StrTran( StrTran( tmp, '"' ), "%HOME%\" ) )
NEXT
EXIT
CASE "Define"