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

2012-07-18 13:54 UTC+0200 Viktor Szakats (harbour syenar.net)

Browse Source 
+ contrib/hbgt/tests
  + contrib/hbgt/tests/test.prg
  + contrib/hbmisc/tests/rtfclass.prg
  - tests/rtfclass.prg
  - tests/test10.prg
  - tests/testgt.prg
  * tests/ac_test.prg
  * tests/alias.prg
  * tests/begin.prg
  * tests/boxtest.prg
  * tests/cdow.prg
  * tests/clasinh.prg
  * tests/dates.prg
  * tests/dates2.prg
  * tests/dates3.prg
  * tests/dates4.prg
  * tests/ddate.prg
  * tests/debugtst.prg
  * tests/delimtst.prg
  * tests/devtest.prg
  * tests/disptest.prg
  * tests/foreach.prg
  * tests/gtstdtst.prg
  * tests/ipclnt.prg
  * tests/ipsvr.prg
  * tests/langapi.prg
  * tests/memtst.prg
  * tests/memvar.prg
  * tests/menutest.prg
  * tests/mousetst.prg
  * tests/multiarg.prg
  * tests/newrdd.prg
  * tests/nums.prg
  * tests/objarr.prg
  * tests/objasign.prg
  * tests/objects.prg
  * tests/omacro.prg
  * tests/onidle.prg
  * tests/os.prg
  * tests/output.prg
  * tests/overload.prg
  * tests/parexpr.prg
  * tests/passref.prg
  * tests/procline.prg
  * tests/procname.prg
  * tests/recursiv.prg
  * tests/returns.prg
  * tests/round.prg
  * tests/say.prg
  * tests/sbartest.prg
  * tests/scroll.prg
  * tests/sdf_test.prg
  * tests/seconds.prg
  * tests/server.prg
  * tests/set_num.prg
  * tests/set_test.prg
  * tests/setkeys.prg
  * tests/sound.prg
  * tests/speed.prg
  * tests/statfun.prg
  * tests/statics.prg
  * tests/statics1.prg
  * tests/statics2.prg
  * tests/statinit.prg
  * tests/strdelim.prg
  * tests/stripem.prg
  * tests/switch.prg
  * tests/symbolt.prg
  * tests/t1.prg
  * tests/tb1.prg
  * tests/testbrdb.prg
  * tests/testbrw.prg
  * tests/testcdx.prg
  * tests/testcls.prg
  * tests/testdbf.prg
  * tests/testdecl.prg
  * tests/testerro.prg
  * tests/testfor.prg
  * tests/testget.prg
  * tests/testhrb.prg
  * tests/testhtml.prg
  * tests/testidle.prg
  * tests/testmem.prg
  * tests/testpers.prg
  * tests/testtok.prg
  * tests/testwarn.prg
  * tests/tstalias.prg
  * tests/tstasort.prg
  * tests/tstblock.prg
  * tests/tstdbi.prg
  * tests/tstmacro.prg
  * tests/varparam.prg
  * tests/wvt_fs.prg
    * cleaning up tests
This commit is contained in:
Viktor Szakats
2012-07-18 12:00:10 +00:00
parent d80c8c5454
commit e788d6d3e8
93 changed files with 2559 additions and 2345 deletions
Download Patch File Download Diff File Expand all files Collapse all files

96
harbour/ChangeLog
View File

@@ -16,6 +16,102 @@
The license applies to all entries newer than 2009-04-28.
*/
2012-07-18 13:54 UTC+0200 Viktor Szakats (harbour syenar.net)
+ contrib/hbgt/tests
+ contrib/hbgt/tests/test.prg
+ contrib/hbmisc/tests/rtfclass.prg
- tests/rtfclass.prg
- tests/test10.prg
- tests/testgt.prg
* tests/ac_test.prg
* tests/alias.prg
* tests/begin.prg
* tests/boxtest.prg
* tests/cdow.prg
* tests/clasinh.prg
* tests/dates.prg
* tests/dates2.prg
* tests/dates3.prg
* tests/dates4.prg
* tests/ddate.prg
* tests/debugtst.prg
* tests/delimtst.prg
* tests/devtest.prg
* tests/disptest.prg
* tests/foreach.prg
* tests/gtstdtst.prg
* tests/ipclnt.prg
* tests/ipsvr.prg
* tests/langapi.prg
* tests/memtst.prg
* tests/memvar.prg
* tests/menutest.prg
* tests/mousetst.prg
* tests/multiarg.prg
* tests/newrdd.prg
* tests/nums.prg
* tests/objarr.prg
* tests/objasign.prg
* tests/objects.prg
* tests/omacro.prg
* tests/onidle.prg
* tests/os.prg
* tests/output.prg
* tests/overload.prg
* tests/parexpr.prg
* tests/passref.prg
* tests/procline.prg
* tests/procname.prg
* tests/recursiv.prg
* tests/returns.prg
* tests/round.prg
* tests/say.prg
* tests/sbartest.prg
* tests/scroll.prg
* tests/sdf_test.prg
* tests/seconds.prg
* tests/server.prg
* tests/set_num.prg
* tests/set_test.prg
* tests/setkeys.prg
* tests/sound.prg
* tests/speed.prg
* tests/statfun.prg
* tests/statics.prg
* tests/statics1.prg
* tests/statics2.prg
* tests/statinit.prg
* tests/strdelim.prg
* tests/stripem.prg
* tests/switch.prg
* tests/symbolt.prg
* tests/t1.prg
* tests/tb1.prg
* tests/testbrdb.prg
* tests/testbrw.prg
* tests/testcdx.prg
* tests/testcls.prg
* tests/testdbf.prg
* tests/testdecl.prg
* tests/testerro.prg
* tests/testfor.prg
* tests/testget.prg
* tests/testhrb.prg
* tests/testhtml.prg
* tests/testidle.prg
* tests/testmem.prg
* tests/testpers.prg
* tests/testtok.prg
* tests/testwarn.prg
* tests/tstalias.prg
* tests/tstasort.prg
* tests/tstblock.prg
* tests/tstdbi.prg
* tests/tstmacro.prg
* tests/varparam.prg
* tests/wvt_fs.prg
* cleaning up tests
2012-07-18 12:43 UTC+0200 Viktor Szakats (harbour syenar.net)
* contrib/hbct/addascii.c
* contrib/hbct/ascpos.c

25
harbour/contrib/hbgt/tests/test.prg Normal file
View File

@@ -0,0 +1,25 @@
/*
* $Id$
*/
PROCEDURE Main()
QOut( 'gt_ascpos("Harbour",1) => ' + LTrim( Str(gt_ascpos("Harbour",1 ) ) ) )
QOut( 'gt_atdiff("This Is Harbour","This Is Clipper") => ' + LTrim( Str(gt_atdiff("This Is Harbour","This Is Clipper" ) ) ) )
QOut( 'gt_chareven("The_Power_Of_Harbour") => ' + gt_chareven( "The_Power_Of_Harbour" ) )
QOut( 'gt_charodd("The_Power_Of_Harbour") => ' + gt_charodd( "The_Power_Of_Harbour" ) )
QOut( 'gt_chrcount("s","she sells shells by the sea shore") => ' + LTrim( Str(gt_chrcount("s","she sells shells by the sea shore" ) ) ) )
QOut( 'gt_chrtotal("sl","she sells shells by the sea shore") => ' + LTrim( Str(gt_chrtotal("sl","she sells shells by the sea shore" ) ) ) )
QOut( 'gt_charmix("CLIPPER","harbour") => ' + gt_charmix( "CLIPPER","harbour" ) )
QOut( 'gt_asciisum("harbour") => ' + LTrim( Str(gt_asciisum("harbour" ) ) ) )
QOut( 'gt_chrfirst("Ho", "the power of Harbour") => ' + LTrim( Str(gt_chrfirst("Ho", "the power of Harbour" ) ) ) )
QOut( 'gt_strcount("the", "the cat sat on the mat") => ' + LTrim( Str(gt_strcount("the", "the cat sat on the mat" ) ) ) )
QOut( 'gt_strcspn("this is a test", "as ") => ' + LTrim( Str(gt_strcspn("this is a test", "as " ) ) ) )
QOut( 'gt_strcspn("this is a test", "elnjpq") => ' + LTrim( Str(gt_strcspn("this is a test", "elnjpq" ) ) ) )
QOut( 'gt_strDiff("the cat", "the rat") => ' + gt_strDiff( "the cat", "the rat" ) )
QOut( 'gt_strexpand("HARBOUR", 2,"-") => ' + gt_strexpand( "HARBOUR", 2,"-" ) )
QOut( 'gt_strleft("this is a test", "hsit ") => ' + LTrim( Str(gt_strleft("this is a test", "hsit " ) ) ) )
QOut( 'gt_strpbrk("this is a test", "sa ") => ' + gt_strpbrk( "this is a test", "sa " ) )
QOut( 'gt_strright("this is a test", "teas ") => ' + LTrim( Str(gt_strright("this is a test", "teas " ) ) ) )
RETURN

166
harbour/contrib/hbmisc/tests/rtfclass.prg Normal file
View File

@@ -0,0 +1,166 @@
/*
* $Id$
*/
/*
* harbour rtfclass demo
* notes : - raw enough but it works
- using hb_f*() - some compilers are not friendly with this :(
- rtf is assumed to have association
* initial release : 23 June 1999 Andi Jahja
* tested under Windows 98 only with RTF associated to Winword
* works with printable ascii only
* placed in the public domain
*/
#define CRLF CHR(13) + CHR(10)
PROCEDURE Main()
LOCAL ortf := trtf():new( "test.rtf" )
LOCAL htest := FCreate( "rtf_test.txt" )
LOCAL ctest := ""
// create a plain text file
ctest += "This is +bHarbour © RTF Class-b" + CRLF
ctest += "THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG" + CRLF
ctest += "+bTHE QUICK BROWN FOX JUMPS OVER THE LAZY DOG-b" + CRLF
ctest += "+iTHE QUICK BROWN FOX JUMPS OVER THE LAZY DOG-i" + CRLF
ctest += "+buTHE QUICK BROWN FOX JUMPS OVER THE LAZY DOG-bu" + CRLF
ctest += "+buiTHE QUICK BROWN FOX JUMPS OVER THE LAZY DOG-bui" + CRLF
ctest += "THE +bQUICK-b +buBROWN-bu +buiFOX-bui +iJUMPS-i +uOVER-u +ilTHE-il +uLAZY-u +buDOG-bu" + CRLF
FWrite( htest, ctest )
FClose( htest )
// convert text file to rtf
ortf:write( "rtf_test.txt" )
ortf:close()
// execute file association ( windows only )
IF Lower( OS() ) == "windows"
// assuming start.exe is exist
__Run( "start test.rtf" )
ENDIF
RETURN
FUNCTION trtf()
STATIC oclass
IF oclass == nil
oclass := HBClass():new( "trtf" )
oclass:adddata( "nhandle" )
oclass:addmethod( "new", @new() )
oclass:addmethod( "write", @write() )
oclass:addmethod( "close", @close() )
oclass:create()
ENDIF
RETURN oclass:instance()
STATIC FUNCTION new( cfilename )
LOCAL self := qself()
::nhandle := FCreate( cfilename )
FWrite( ::nhandle, ;
"{\rtf1\ansi\deff0{\fonttbl {\f0\fnil\fcharset0 Courier New;}{\f1\fnil\fcharset0 Arial;}}" + ;
"\uc1\pard\lang1033\ulnone\f0\fs20" + CRLF )
RETURN self
STATIC FUNCTION write( csource )
LOCAL self := qself()
LOCAL cchar, cline, xatt, i, _xatt
LOCAL n, nchar, xchar, y
// These are character attributes, self-defined
// + means a turn-on
// - means a turn-off
LOCAL attrib := { ;
{ "+b" , "\b " } /* turn bold on*/
, ;
{ "+bu" , "\ul\b " } /* turn bold_underline on */
, ;
{ "+bi" , "\b\i " } /* turn bold_italic on */
, ;
{ "+bui", "\ul\b\i " } /* turn bold_underline_italic on */
, ;
{ "+i" , "\i " } /* turn italic on */
, ;
{ "+il" , "\ul\i " } /* turn italic_underline on */
, ;
{ "+u" , "\ul " } /* turn underline on */
, ;
{ "-b" , "\b0 " } /* turn bold off */
, ;
{ "-bu" , "\b0\ulnone " } /* turn bold_underline off */
, ;
{ "-bi" , "\b0\i0 " } /* turn bold_italic off */
, ;
{ "-bui", "\b0\i0\ulnone " } /* turn bold_underline_italic off */
, ;
{ "-i" , "\i0 " } /* turn italic off */
, ;
{ "-il" , "\ulnone\i0 " } /* turn italic_underline off */
, ;
{ "-u" , "\ulnone " } /* turn underline off */
}
hb_fuse( csource ) // open source file
WHILE !hb_FEof() // read the file line by line
cline := hb_freadln() + "\par"
y := Len( cline )
for nchar := 1 TO y
cchar := SubStr( cline, nchar, 1 )
// todo : i need function dec2hex()
// to convert ascii to 2-characters hex
// ie : dec2hex( "H" ) -> 48
IF cchar == "+" .OR. cchar == "-"
xatt := cchar + ;
SubStr( cline, nchar + 1, 1 ) + ;
SubStr( cline, nchar + 2, 1 ) + ;
SubStr( cline, nchar + 3, 1 )
IF ( i := AScan( attrib, { |e| e[1] == xatt } ) ) > 0
FWrite( ::nhandle, attrib[i][2] )
nchar := nchar + Len( xatt ) - 1
ELSE
// 3 attributes
xatt := Left( xatt, 3 )
IF ( i := AScan( attrib, { |e| e[1] == xatt } ) ) > 0
FWrite( ::nhandle, attrib[i][2] )
nchar := nchar + Len( xatt ) - 1
ELSE
// 2 attributes
xatt := Left( xatt, 2 )
IF ( i := AScan( attrib, { |e| e[1] == xatt } ) ) > 0
FWrite( ::nhandle, attrib[i][2] )
nchar := nchar + Len( xatt ) - 1
ELSE
FWrite( ::nhandle, cchar )
ENDIF
ENDIF
ENDIF
ELSE
FWrite( ::nhandle, cchar )
ENDIF
next
FWrite( ::nhandle, CRLF )
hb_fskip() // read next line
ENDDO
hb_fuse()
RETURN ( self )
STATIC FUNCTION CLOSE()
LOCAL self := qself()
FWrite( ::nhandle, "\f1\fs16\par" + CRLF + "}" )
FClose( ::nhandle )
RETURN self

2
harbour/tests/ac_test.prg
View File

@@ -27,7 +27,7 @@
//+--------------------------------------------------------------------
//+
PROCEDURE main()
PROCEDURE Main()
LOCAL aPrompts := { ;
"AGRI-PLANTS" , ;

231
harbour/tests/alias.prg
View File

@@ -1,133 +1,136 @@
//NOTEST
// $Id$
//
//It is used to check if pcode is generated correctly for aliased expressions
//(you must check it visually :)
//
PROCEDURE MAIN()
LOCAL localVar
STATIC staticVar
FIELD fieldVar
FIELD aliasedField IN aaa
MEMVAR memvarVar
PRIVATE privateVar
/*
* $Id$
*/
? privateVar
? memvarVar
? localVar
? staticVar
? fieldVar
? aliasedField
? unknVar
// It is used to check if pcode is generated correctly for aliased expressions
// (you must check it visually :)
? 1->privateVar
? 1->memvarVar
? 1->localVar
? 1->staticVar
? 1->fieldVar
? 1->aliasedField
? 1->unknVar
PROCEDURE Main()
? alias->privateVar
? alias->memvarVar
? alias->localVar
? alias->staticVar
? alias->fieldVar
? alias->aliasedField
? alias->unknVar
LOCAL localVar
STATIC staticVar
FIELD fieldVar
FIELD aliasedField IN aaa
MEMVAR memvarVar
PRIVATE privateVar
? ( localVar )->privateVar
? ( localVar )->memvarVar
? ( localVar )->localVar
? ( localVar )->staticVar
? ( localVar )->fieldVar
? ( localVar )->aliasedField
? ( localVar )->unknVar
? privateVar
? memvarVar
? localVar
? staticVar
? fieldVar
? aliasedField
? unknVar
? ( localVar )->( privateVar, memvarVar, localVar, staticVar, fieldVar, aliasedField, unknVar )
? alias->( privateVar, memvarVar, localVar, staticVar, fieldVar, aliasedField, unknVar )
? 2->( privateVar, memvarVar, localVar, staticVar, fieldVar, aliasedField, unknVar )
? ( localVar, 2 )->( privateVar, memvarVar, localVar, staticVar, fieldVar, aliasedField, unknVar )
? 1->privateVar
? 1->memvarVar
? 1->localVar
? 1->staticVar
? 1->fieldVar
? 1->aliasedField
? 1->unknVar
? privateVar++
? memvarVar++
? localVar++
? staticVar++
? fieldVar++
? aliasedField++
? unknVar++
? alias->privateVar
? alias->memvarVar
? alias->localVar
? alias->staticVar
? alias->fieldVar
? alias->aliasedField
? alias->unknVar
? 1->privateVar++
? 1->memvarVar++
? 1->localVar++
? 1->staticVar++
? 1->fieldVar++
? 1->aliasedField++
? 1->unknVar++
? ( localVar )->privateVar
? ( localVar )->memvarVar
? ( localVar )->localVar
? ( localVar )->staticVar
? ( localVar )->fieldVar
? ( localVar )->aliasedField
? ( localVar )->unknVar
? alias->privateVar++
? alias->memvarVar++
? alias->localVar++
? alias->staticVar++
? alias->fieldVar++
? alias->aliasedField++
? alias->unknVar++
? ( localVar )->( privateVar, memvarVar, localVar, staticVar, fieldVar, aliasedField, unknVar )
? alias->( privateVar, memvarVar, localVar, staticVar, fieldVar, aliasedField, unknVar )
? 2->( privateVar, memvarVar, localVar, staticVar, fieldVar, aliasedField, unknVar )
? ( localVar, 2 )->( privateVar, memvarVar, localVar, staticVar, fieldVar, aliasedField, unknVar )
? ( localVar )->privateVar++
? ( localVar )->memvarVar++
? ( localVar )->localVar++
? ( localVar )->staticVar++
? ( localVar )->fieldVar++
? ( localVar )->aliasedField++
? ( localVar )->unknVar++
? privateVar ++
? memvarVar ++
? localVar ++
? staticVar ++
? fieldVar ++
? aliasedField ++
? unknVar ++
? privateVar +=privateVar
? memvarVar +=memvarVar
? localVar +=localVar
? staticVar +=staticVar
? fieldVar +=fieldVar
? aliasedField +=aliasedField
? unknVar +=unknVar
? 1->privateVar ++
? 1->memvarVar ++
? 1->localVar ++
? 1->staticVar ++
? 1->fieldVar ++
? 1->aliasedField ++
? 1->unknVar ++
? 1->privateVar +=1->privateVar
? 1->memvarVar +=1->memvarVar
? 1->localVar +=1->localVar
? 1->staticVar +=1->staticVar
? 1->fieldVar +=1->fieldVar
? 1->aliasedField +=1->aliasedField
? 1->unknVar +=1->unknVar
? alias->privateVar ++
? alias->memvarVar ++
? alias->localVar ++
? alias->staticVar ++
? alias->fieldVar ++
? alias->aliasedField ++
? alias->unknVar ++
? alias->privateVar +=alias->privateVar
? alias->memvarVar +=alias->memvarVar
? alias->localVar +=alias->localVar
? alias->staticVar +=alias->staticVar
? alias->fieldVar +=alias->fieldVar
? alias->aliasedField +=alias->aliasedField
? alias->unknVar +=alias->unknVar
? ( localVar )->privateVar ++
? ( localVar )->memvarVar ++
? ( localVar )->localVar ++
? ( localVar )->staticVar ++
? ( localVar )->fieldVar ++
? ( localVar )->aliasedField ++
? ( localVar )->unknVar ++
? ( localVar )->privateVar +=( localVar )->privateVar
? ( localVar )->memvarVar +=( localVar )->memvarVar
? ( localVar )->localVar +=( localVar )->localVar
? ( localVar )->staticVar +=( localVar )->staticVar
? ( localVar )->fieldVar +=( localVar )->fieldVar
? ( localVar )->aliasedField +=( localVar )->aliasedField
? ( localVar )->unknVar +=( localVar )->unknVar
? privateVar += privateVar
? memvarVar += memvarVar
? localVar += localVar
? staticVar += staticVar
? fieldVar += fieldVar
? aliasedField += aliasedField
? unknVar += unknVar
? ( localVar )->privateVar +=2->privateVar
? ( localVar )->memvarVar +=2->memvarVar
? ( localVar )->localVar +=2->localVar
? ( localVar )->staticVar +=2->staticVar
? ( localVar )->fieldVar +=2->fieldVar
? ( localVar )->aliasedField +=2->aliasedField
? ( localVar )->unknVar +=2->unknVar
? 1->privateVar += 1->privateVar
? 1->memvarVar += 1->memvarVar
? 1->localVar += 1->localVar
? 1->staticVar += 1->staticVar
? 1->fieldVar += 1->fieldVar
? 1->aliasedField += 1->aliasedField
? 1->unknVar += 1->unknVar
? alias->( aliasedField, MEMVAR->privateVar, 1->(Test( 2->fieldVar )) )
? alias->privateVar += alias->privateVar
? alias->memvarVar += alias->memvarVar
? alias->localVar += alias->localVar
? alias->staticVar += alias->staticVar
? alias->fieldVar += alias->fieldVar
? alias->aliasedField += alias->aliasedField
? alias->unknVar += alias->unknVar
MEMVAR->privateVar :=0
M->localVar :=1
MEMVA->fieldVar :=2
? ( localVar )->privateVar += ( localVar )->privateVar
? ( localVar )->memvarVar += ( localVar )->memvarVar
? ( localVar )->localVar += ( localVar )->localVar
? ( localVar )->staticVar += ( localVar )->staticVar
? ( localVar )->fieldVar += ( localVar )->fieldVar
? ( localVar )->aliasedField += ( localVar )->aliasedField
? ( localVar )->unknVar += ( localVar )->unknVar
FIELD->fieldVar :=0
FIEL->aliasedFieldVar :=1
? ( localVar )->privateVar += 2->privateVar
? ( localVar )->memvarVar += 2->memvarVar
? ( localVar )->localVar += 2->localVar
? ( localVar )->staticVar += 2->staticVar
? ( localVar )->fieldVar += 2->fieldVar
? ( localVar )->aliasedField += 2->aliasedField
? ( localVar )->unknVar += 2->unknVar
RETURN
? alias->( aliasedField, MEMVAR->privateVar, 1->( Test( 2->fieldVar ) ) )
MEMVAR->privateVar := 0
M->localVar := 1
MEMVA->fieldVar := 2
FIELD->fieldVar := 0
FIEL->aliasedFieldVar := 1
RETURN

188
harbour/tests/begin.prg
View File

@@ -1,132 +1,134 @@
//
// $Id$
//
/*
* $Id$
*/
// This files demonstrates the use of BEGIN/RECOVER/END SEQUENCE
// and BREAK statement
//
MEMVAR oMemvar
MEMVAR mPrivate
PROCEDURE MAIN
LOCAL oLocal
PRIVATE mPrivate:='private value in MAIN'
PROCEDURE Main()
LOCAL oLocal
PRIVATE mPrivate := 'private value in MAIN'
BEGIN SEQUENCE
? " Inside SEQUENCE 1"
? " No break issued...."
RECOVER
? " Recovering in 1 ..."
END SEQUENCE
? "After SEQUENCE 1"
BEGIN SEQUENCE
? " Inside SEQUENCE 1"
? " No break issued...."
RECOVER
? " Recovering in 1 ..."
END SEQUENCE
? "After SEQUENCE 1"
BEGIN SEQUENCE
? " Inside SEQUENCE 2"
Break( "VALUE 2" )
RECOVER USING oLocal
? " Recovering in 2 using....", oLocal
END SEQUENCE
? "After SEQUENCE 2"
BEGIN SEQUENCE
? " Inside SEQUENCE 2"
Break( "VALUE 2" )
RECOVER USING oLocal
? " Recovering in 2 using....", oLocal
END SEQUENCE
? "After SEQUENCE 2"
BEGIN SEQUENCE
? " Inside SEQUENCE 3"
Break
RECOVER USING oLocal
? " Recovering in 3 using....", oLocal
END SEQUENCE
? "After SEQUENCE 3"
BEGIN SEQUENCE
? " Inside SEQUENCE 3"
Break
RECOVER USING oLocal
? " Recovering in 3 using....", oLocal
END SEQUENCE
? "After SEQUENCE 3"
BEGIN SEQUENCE
? " Inside SEQUENCE 4"
Break
? " Recovering in 4 using....", oLocal
END SEQUENCE
? "After SEQUENCE 4"
BEGIN SEQUENCE
? " Inside SEQUENCE 4"
Break
? " Recovering in 4 using....", oLocal
END SEQUENCE
? "After SEQUENCE 4"
BEGIN SEQUENCE
? " Inside SEQUENCE 5"
Break1( )
? " Recovering in 5 using....", oLocal
END SEQUENCE
? "After SEQUENCE 5"
BEGIN SEQUENCE
? " Inside SEQUENCE 5"
Break1( )
? " Recovering in 5 using....", oLocal
END SEQUENCE
? "After SEQUENCE 5"
BEGIN SEQUENCE
? " Inside SEQUENCE 6"
Break1( )
RECOVER USING oMemvar
? " Recovering in 6 using... ", oMemvar
END SEQUENCE
? "After SEQUENCE 6"
BEGIN SEQUENCE
? " Inside SEQUENCE 6"
Break1( )
RECOVER USING oMemvar
? " Recovering in 6 using... ", oMemvar
END SEQUENCE
? "After SEQUENCE 6"
BEGIN SEQUENCE
? " Inside SEQUENCE 7"
Break2( )
RECOVER USING oMemvar
? " Recovering in 7 using... ", oMemvar
END SEQUENCE
? "After SEQUENCE 7"
? M->mPrivate
Break( "exit from MAIN" )
? "This text will be not printed"
BEGIN SEQUENCE
? " Inside SEQUENCE 7"
Break2( )
RECOVER USING oMemvar
? " Recovering in 7 using... ", oMemvar
END SEQUENCE
? "After SEQUENCE 7"
? M->mPrivate
BREAK( "exit from MAIN" )
? "This text will be not printed"
RETURN
RETURN
PROCEDURE Break1()
PRIVATE mPrivate:='VALUE from Break1'
BREAK M->mPrivate
PRIVATE mPrivate := 'VALUE from Break1'
RETURN
BREAK M->mPrivate
RETURN
PROCEDURE Break2()
BEGIN SEQUENCE
? " Inside SEQUENCE 8"
Break3( )
RECOVER USING oMemvar
? " Recovering in 8 using...", EVAL( oMemvar, ' eval in 8' )
BREAK( "BREAK from recovery code" )
END SEQUENCE
? "After SEQUENCE 8"
RETURN
BEGIN SEQUENCE
? " Inside SEQUENCE 8"
Break3( )
RECOVER USING oMemvar
? " Recovering in 8 using...", Eval( oMemvar, ' eval in 8' )
Break( "BREAK from recovery code" )
END SEQUENCE
? "After SEQUENCE 8"
RETURN
PROCEDURE Break3()
STATIC oStatic
BEGIN SEQUENCE
? " Inside SEQUENCE 9"
STATIC oStatic
BEGIN SEQUENCE
? " Inside SEQUENCE 10"
Break( "value from nested SEQUENCE 10" )
RECOVER USING oStatic
? " Recovering in 10 using...", oStatic
END SEQUENCE
? "After SEQUENCE 10"
BEGIN SEQUENCE
? " Inside SEQUENCE 9"
Break4( " and parameter" )
BEGIN SEQUENCE
? " Inside SEQUENCE 10"
Break( "value from nested SEQUENCE 10" )
RECOVER USING oStatic
? " Recovering in 10 using...", oStatic
END SEQUENCE
? "After SEQUENCE 10"
RECOVER USING oMemvar
? " Recovering in 9 using...", EVAL( oMemvar, ' eval in 9' )
BREAK( oMemvar )
END SEQUENCE
? "After SEQUENCE 9"
Break4( " and parameter" )
RETURN
RECOVER USING oMemvar
? " Recovering in 9 using...", Eval( oMemvar, ' eval in 9' )
Break( oMemvar )
END SEQUENCE
? "After SEQUENCE 9"
RETURN
PROCEDURE Break4( cValue )
LOCAL oLocal:=' detached Break4 '
BREAK( {|x| oLocal + x + cValue} )
LOCAL oLocal := ' detached Break4 '
RETURN
Break( {| x | oLocal + x + cValue } )
RETURN

26
harbour/tests/boxtest.prg
View File

@@ -2,30 +2,32 @@
* $Id$
*/
function main()
PROCEDURE Main()
CLS
@ 0, 0, 15, 50 BOX " " COLOR "W+/B"
MESSAGE( [@ 0, 0, 15, 50 BOX " " COLOR "W+/B"] )
__BOX( 1, 1, 5, 7 )
__Box( 1, 1, 5, 7 )
MESSAGE( [__BOX( 1, 1, 5, 7 )] )
__BOX( 1, 1, 5, 7, "X" )
__Box( 1, 1, 5, 7, "X" )
MESSAGE( [__BOX( 1, 1, 5, 7, "X" )] )
__BOXD( 2, 2, 6, 8 )
__BoxD( 2, 2, 6, 8 )
MESSAGE( [__BOXD( 2, 2, 6, 8 )] )
__BOXS( 3, 3, 7, 9 )
__BoxS( 3, 3, 7, 9 )
MESSAGE( [__BOXS( 3, 3, 7, 9 )] )
return nil
RETURN
procedure MESSAGE( cText )
@ 16,0 CLEAR TO 16,79
@ 16,0 SAY cText
OUTSTD( CHR( 7 ) )
INKEY( 0 )
return
PROCEDURE MESSAGE( cText )
@ 16, 0 CLEAR TO 16, 79
@ 16, 0 SAY cText
OutStd( Chr( 7 ) )
Inkey( 0 )
RETURN

2
harbour/tests/cdow.prg
View File

@@ -2,7 +2,7 @@
* $Id$
*/
PROCEDURE main()
PROCEDURE Main()
OutStd( cMonth( date() ) + hb_eol() )
OutStd( cMonth( date() + 31 ) + hb_eol() )

38
harbour/tests/clasinh.prg
View File

@@ -4,25 +4,35 @@
#include "hbclass.ch"
function main()
local oObject, oBase
PROCEDURE Main()
LOCAL oObject, oBase
oObject := TAnyClass():New()
oBase := TClassBase():New()
return nil
class TClassBase
method New()
method Test() INLINE Alert( "Test" )
endclass
RETURN
method New() class TClassBase
return Self
CREATE CLASS TClassBase
class TAnyClass from TClassBase
method New()
endclass
METHOD New()
METHOD Test() INLINE Alert( "Test" )
ENDCLASS
METHOD New() CLASS TClassBase
RETURN Self
CREATE CLASS TAnyClass FROM TClassBase
METHOD New()
ENDCLASS
METHOD New() CLASS TAnyClass
method New() class TAnyClass
super:New()
super:Test()
return Self
RETURN Self

114
harbour/tests/dates.prg
View File

@@ -6,84 +6,86 @@
#include "set.ch"
function Main()
PROCEDURE Main()
local dDate, dDate2, cMask, cDate
LOCAL dDate, dDate2, cMask, cDate
OUTSTD (hb_eol(), "Testing Harbour dates management on", DATE())
OutStd( hb_eol(), "Testing Harbour dates management on", Date() )
TestCentury()
OUTSTD (hb_eol(), "")
OUTSTD (hb_eol(), "dDate := CToD( '02/04/1999' ) =>", dDate := CToD( "02/04/1999" ))
OutStd( hb_eol(), "" )
OutStd( hb_eol(), "dDate := CToD( '02/04/1999' ) =>", dDate := CToD( "02/04/1999" ) )
OUTSTD (hb_eol(), "ValType( dDate ) =", ValType( dDate ))
OutStd( hb_eol(), "ValType( dDate ) =", ValType( dDate ) )
OUTSTD (hb_eol(), "Day( dDate ) =", Day( dDate ))
OUTSTD (hb_eol(), "Month( dDate ) =", Month( dDate ))
OUTSTD (hb_eol(), "Year( dDate ) =", Year( dDate ), hb_eol())
OutStd( hb_eol(), "Day( dDate ) =", Day( dDate ) )
OutStd( hb_eol(), "Month( dDate ) =", Month( dDate ) )
OutStd( hb_eol(), "Year( dDate ) =", Year( dDate ), hb_eol() )
OUTSTD (hb_eol(), "dDate + 5 =", dDate2 := dDate + 5)
OUTSTD (hb_eol(), "dDate - 5 =", dDate - 5, hb_eol() )
OutStd( hb_eol(), "dDate + 5 =", dDate2 := dDate + 5 )
OutStd( hb_eol(), "dDate - 5 =", dDate - 5, hb_eol() )
OUTSTD (hb_eol(), "dDate2 - dDate =", dDate2 - dDate)
OutStd( hb_eol(), "dDate2 - dDate =", dDate2 - dDate )
OUTSTD (hb_eol(), "")
OUTSTD (hb_eol(), dDate, DTOS (dDate))
OutStd( hb_eol(), "" )
OutStd( hb_eol(), dDate, DToS ( dDate ) )
OUTSTD (hb_eol(), "19990429", STOD ("19990429"))
OutStd( hb_eol(), "19990429", SToD ( "19990429" ) )
OUTSTD (hb_eol(), "")
SET (_SET_EPOCH, 1950)
OutStd( hb_eol(), "" )
SET ( _SET_EPOCH, 1950 )
cMask := "dd/mm/yyyy"
cDate := "02/04/49"
SET (_SET_DATEFORMAT, cMask)
dDate := CTOD (cDate)
OUTSTD (hb_eol(), cDate, cMask, dDate, DTOS (dDate), DTOC (dDate))
SET ( _SET_DATEFORMAT, cMask )
dDate := CToD ( cDate )
OutStd( hb_eol(), cDate, cMask, dDate, DToS ( dDate ), DToC ( dDate ) )
OUTSTD (hb_eol(), "")
OutStd( hb_eol(), "" )
cMask := "mm/dd/yyyy"
SET (_SET_DATEFORMAT, cMask)
dDate := CTOD (cDate)
OUTSTD (hb_eol(), cDate, cMask, dDate, DTOS (dDate), DTOC (dDate))
SET ( _SET_DATEFORMAT, cMask )
dDate := CToD ( cDate )
OutStd( hb_eol(), cDate, cMask, dDate, DToS ( dDate ), DToC ( dDate ) )
OUTSTD (hb_eol(), "")
OutStd( hb_eol(), "" )
cMask := "yyyy/mm/dd"
SET (_SET_DATEFORMAT, cMask)
dDate := CTOD (cDate)
OUTSTD (hb_eol(), cDate, cMask, dDate, DTOS (dDate), DTOC (dDate))
OUTSTD (hb_eol(), "")
OUTSTD (hb_eol(), "49/02/04", cMask, CTOD ("49/02/04"))
SET ( _SET_DATEFORMAT, cMask )
dDate := CToD ( cDate )
OutStd( hb_eol(), cDate, cMask, dDate, DToS ( dDate ), DToC ( dDate ) )
OutStd( hb_eol(), "" )
OutStd( hb_eol(), "49/02/04", cMask, CToD ( "49/02/04" ) )
TestCentury(hb_eol())
TestCentury( hb_eol() )
OUTSTD (hb_eol(), "")
OutStd( hb_eol(), "" )
cMask := "yyyy/dd/mm"
SET (_SET_DATEFORMAT, cMask)
dDate := CTOD (cDate)
OUTSTD (hb_eol(), cDate, cMask, dDate, DTOS (dDate), DTOC (dDate))
OUTSTD (hb_eol(), "")
OUTSTD (hb_eol(), "49/02/04", cMask, CTOD ("49/02/04"))
SET ( _SET_DATEFORMAT, cMask )
dDate := CToD ( cDate )
OutStd( hb_eol(), cDate, cMask, dDate, DToS ( dDate ), DToC ( dDate ) )
OutStd( hb_eol(), "" )
OutStd( hb_eol(), "49/02/04", cMask, CToD ( "49/02/04" ) )
OUTSTD (hb_eol(), "")
OutStd( hb_eol(), "" )
cMask := "ddd/mmm/yy"
SET (_SET_DATEFORMAT, cMask)
dDate := CTOD (cDate)
OUTSTD (hb_eol(), cDate, cMask, dDate, DTOS (dDate), DTOC (dDate))
SET ( _SET_DATEFORMAT, cMask )
dDate := CToD ( cDate )
OutStd( hb_eol(), cDate, cMask, dDate, DToS ( dDate ), DToC ( dDate ) )
return nil
RETURN
procedure TestCentury()
OUTSTD (hb_eol(), "")
OUTSTD (hb_eol(), __SETCENTURY ())
__SETCENTURY ("ON")
OUTSTD (__SETCENTURY ())
__SETCENTURY ("OFF")
OUTSTD (__SETCENTURY ())
__SETCENTURY ("GIBBERISH")
OUTSTD (__SETCENTURY ())
__SETCENTURY (.T.)
OUTSTD (__SETCENTURY ())
__SETCENTURY (5)
OUTSTD (__SETCENTURY ())
return
PROCEDURE TestCentury()
OutStd( hb_eol(), "" )
OutStd( hb_eol(), __SetCentury () )
__SetCentury ( "ON" )
OutStd ( __SetCentury () )
__SetCentury ( "OFF" )
OutStd ( __SetCentury () )
__SetCentury ( "GIBBERISH" )
OutStd ( __SetCentury () )
__SetCentury ( .T. )
OutStd ( __SetCentury () )
__SetCentury ( 5 )
OutStd ( __SetCentury () )
RETURN

69
harbour/tests/dates2.prg
View File

@@ -4,39 +4,40 @@
#include "set.ch"
function main()
local dDate := CTOD ("04/30/99")
PROCEDURE Main()
outstd (SET (_SET_DATEFORMAT), dDate, hb_eol())
set (_SET_DATEFORMAT, "yyy/mm/ddd")
outstd (SET (_SET_DATEFORMAT), dDate, hb_eol())
__SETCENTURY ( "on" )
outstd (SET (_SET_DATEFORMAT), dDate, hb_eol())
__SETCENTURY ( "off" )
outstd (SET (_SET_DATEFORMAT), dDate, hb_eol())
set (_SET_DATEFORMAT, "yyy/m/d/yyy")
outstd (SET (_SET_DATEFORMAT), dDate, hb_eol())
__SETCENTURY ( "on" )
outstd (SET (_SET_DATEFORMAT), dDate, hb_eol())
__SETCENTURY ( "off" )
outstd (SET (_SET_DATEFORMAT), dDate, hb_eol())
set (_SET_DATEFORMAT, "m/d/y/m/d")
outstd (SET (_SET_DATEFORMAT), dDate, hb_eol())
__SETCENTURY ( "on" )
outstd (SET (_SET_DATEFORMAT), dDate, hb_eol())
__SETCENTURY ( "off" )
outstd (SET (_SET_DATEFORMAT), dDate, hb_eol())
set (_SET_DATEFORMAT, "mmmm/ddddd")
outstd (SET (_SET_DATEFORMAT), dDate, hb_eol())
__SETCENTURY ( "on" )
outstd (SET (_SET_DATEFORMAT), dDate, hb_eol())
__SETCENTURY ( "off" )
outstd (SET (_SET_DATEFORMAT), dDate, hb_eol())
set (_SET_DATEFORMAT, "mmmmm/dd")
outstd (SET (_SET_DATEFORMAT), dDate, hb_eol())
__SETCENTURY ( "on" )
outstd (SET (_SET_DATEFORMAT), dDate, hb_eol())
__SETCENTURY ( "off" )
outstd (SET (_SET_DATEFORMAT), dDate, hb_eol())
LOCAL dDate := hb_SToD( "19990430" )
return nil
OutStd( Set( _SET_DATEFORMAT ), dDate, hb_eol() )
SET( _SET_DATEFORMAT, "yyy/mm/ddd" )
OutStd( Set( _SET_DATEFORMAT ), dDate, hb_eol() )
__SetCentury( "on" )
OutStd( Set( _SET_DATEFORMAT ), dDate, hb_eol() )
__SetCentury( "off" )
OutStd( Set( _SET_DATEFORMAT ), dDate, hb_eol() )
SET( _SET_DATEFORMAT, "yyy/m/d/yyy" )
OutStd( Set( _SET_DATEFORMAT ), dDate, hb_eol() )
__SetCentury( "on" )
OutStd( Set( _SET_DATEFORMAT ), dDate, hb_eol() )
__SetCentury( "off" )
OutStd( Set( _SET_DATEFORMAT ), dDate, hb_eol() )
SET( _SET_DATEFORMAT, "m/d/y/m/d" )
OutStd( Set( _SET_DATEFORMAT ), dDate, hb_eol() )
__SetCentury( "on" )
OutStd( Set( _SET_DATEFORMAT ), dDate, hb_eol() )
__SetCentury( "off" )
OutStd( Set( _SET_DATEFORMAT ), dDate, hb_eol() )
SET( _SET_DATEFORMAT, "mmmm/ddddd" )
OutStd( Set( _SET_DATEFORMAT ), dDate, hb_eol() )
__SetCentury( "on" )
OutStd( Set( _SET_DATEFORMAT ), dDate, hb_eol() )
__SetCentury( "off" )
OutStd( Set( _SET_DATEFORMAT ), dDate, hb_eol() )
SET( _SET_DATEFORMAT, "mmmmm/dd" )
OutStd( Set( _SET_DATEFORMAT ), dDate, hb_eol() )
__SetCentury( "on" )
OutStd( Set( _SET_DATEFORMAT ), dDate, hb_eol() )
__SetCentury( "off" )
OutStd( Set( _SET_DATEFORMAT ), dDate, hb_eol() )
RETURN

36
harbour/tests/dates3.prg
View File

@@ -6,46 +6,48 @@
#include "set.ch"
function main()
PROCEDURE Main()
LOCAL dDate, i
set( _SET_DATEFORMAT, "dd/mm/yyyy" )
dDate := cToD( "25/05/1999" )
SET( _SET_DATEFORMAT, "dd/mm/yyyy" )
dDate := hb_SToD( "19990525" )
OutStd( dDate, dow( dDate ), hb_eol() )
OutStd( dDate, DOW( dDate ), hb_eol() )
OutStd( LastMonday( dDate ), hb_eol() )
dDate += 3
OutStd( dDate, dow( dDate ), hb_eol() )
OutStd( dDate, DOW( dDate ), hb_eol() )
dDate += 4
OutStd( dDate, dow( dDate ), hb_eol() )
OutStd( dDate, DOW( dDate ), hb_eol() )
set( _SET_DATEFORMAT, "mm/dd/yyyy" )
dDate := cToD( "05/25/1999" )
SET( _SET_DATEFORMAT, "mm/dd/yyyy" )
dDate := hb_SToD( "19990525" )
OutStd( dDate, dow( dDate ), hb_eol() )
OutStd( dDate, DOW( dDate ), hb_eol() )
OutStd( LastMonday( dDate ), hb_eol() )
dDate += 3
OutStd( dDate, dow( dDate ), hb_eol() )
OutStd( dDate, DOW( dDate ), hb_eol() )
dDate += 4
OutStd( dDate, dow( dDate ), hb_eol() )
OutStd( dDate, DOW( dDate ), hb_eol() )
OutStd( hb_eol() )
dDate := DATE ()
dDate := Date ()
FOR i := 1 TO 7
OutStd( dDate, dow( dDate ), hb_eol() )
OutStd( dDate, DOW( dDate ), hb_eol() )
dDate++
NEXT
OutStd( ctod( "" ), dow( ctod( "" ) ), hb_eol() )
OutStd( CToD( "" ), DOW( CToD( "" ) ), hb_eol() )
return nil
RETURN
// Like NG's sample
function LastMonday( dDate )
return dDate - dow( dDate ) + 2
FUNCTION LastMonday( dDate )
RETURN dDate - DOW( dDate ) + 2

18
harbour/tests/dates4.prg
View File

@@ -5,20 +5,22 @@
// Testing Harbour dates management.
#include "set.ch"
function main()
PROCEDURE Main()
LOCAL i
LOCAL dDate := date()
LOCAL dDate := Date()
set( _SET_DATEFORMAT, "dd/mm/yyyy" )
SET( _SET_DATEFORMAT, "dd/mm/yyyy" )
for i := 7 to 49 step 7
for i := 7 TO 49 STEP 7
CheckDate( dDate )
dDate += i
next
return nil
RETURN
FUNCTION CheckDate( dDate )
function CheckDate( dDate )
OutStd( "Testing date:", dDate , hb_eol() )
OutStd( "Days in month..:", daysinmonth( dDate ), hb_eol() )
OutStd( "Day of year....:", doy( dDate ), hb_eol() )
@@ -29,6 +31,6 @@ function CheckDate( dDate )
OutStd( "Begin of year..:", boy( dDate ), hb_eol() )
OutStd( "End of year....:", eoy( dDate ), hb_eol() )
__Accept( "Press ENTER to continue..." )
OutStd( chr( 10 ), chr( 10 ) )
OutStd( Chr( 10 ), Chr( 10 ) )
return nil
RETURN nil

9
harbour/tests/ddate.prg
View File

@@ -2,9 +2,10 @@
* $Id$
*/
PROCEDURE MAIN()
LOCAL dDate
LOCAL A
PROCEDURE Main()
LOCAL dDate
LOCAL A
SET DATE FORMAT TO "YYYY.MM.DD"
SET CENTURY ON
@@ -23,7 +24,7 @@ LOCAL A
? "Should be '4' :", 0d20040229 - 0d20040225
? "Should be '0' :", 0d20040229 - 0d20040229
dDate := 0d20000229
? "Should be '2000.02.29' :", dDate

246
harbour/tests/debugtst.prg
View File

@@ -1,6 +1,6 @@
//
// $Id$
//
/*
* $Id$
*/
/*
* $Doc$
@@ -17,10 +17,10 @@
* Placed in the public domain
*/
function Main()
PROCEDURE Main()
local oForm := TForm():New()
local nNumber := 15
LOCAL oForm := TForm():New()
LOCAL nNumber := 15
QOut( oForm:ClassName() )
oForm:Show()
@@ -41,79 +41,79 @@ function Main()
QOut( "Is unknown METHOD ? ", __objHasMethod( oForm, "Unknown" ) )
QOut( "Set nLeft to 50 and nRight to 100" )
oForm:Transfer( {"nLeft", 50}, {"nRight", 100} )
oForm:Transfer( { "nLeft", 50 }, { "nRight", 100 } )
Debug( oForm:Transfer() )
Pause()
QOut( "-DEBUG Functions-")
QOut( "-DEBUG Functions-" )
QOut( "-Statics-" )
Debug( __dbgvmVarSList() )
Debug( __dbgVMVarSList() )
QOut( "-Global Stack-" )
Debug ( __dbgvmStkGList() )
Debug ( __dbgVMStkGList() )
QOut( "-Local Stack-" )
Debug ( __dbgvmStkLList() )
Debug ( __dbgVMStkLList() )
QOut( "-Parameters-" )
Debug ( __dbgvmParLList() )
Debug ( __dbgVMParLList() )
Pause()
FuncSecond( 241, "Hello" )
return nil
RETURN
FUNCTION Pause()
function Pause()
return __Accept("")
RETURN __Accept( "" )
FUNCTION FuncSecond( nParam, cParam, uParam )
function FuncSecond( nParam, cParam, uParam )
local cWhat := "Something"
local nNumber := 2
local xParam
local xStack
LOCAL cWhat := "Something"
LOCAL nNumber := 2
LOCAL xParam
LOCAL xStack
QOut()
QOut( "-Second procedure-")
QOut( "-Second procedure-" )
QOut()
QOut( "-Statics-" )
Debug ( __dbgvmVarSList() )
Debug ( __dbgVMVarSList() )
QOut()
QOut( "-Global Stack- Len=", __dbgvmStkGCount() )
Debug ( __dbgvmStkGList() )
QOut( "-Global Stack- Len=", __dbgVMStkGCount() )
Debug ( __dbgVMStkGList() )
QOut()
QOut( "-Local Stack- Len=", __dbgvmStkLCount() )
xStack := Debug ( __dbgvmStkLList() )
QOut( "-Local Stack- Len=", __dbgVMStkLCount() )
xStack := Debug ( __dbgVMStkLList() )
QOut()
QOut( "-Parameters-" )
xParam := Debug( __dbgvmParLList() )
if xParam[ xStack[ 7 ] ] == "Hello"
xParam := Debug( __dbgVMParLList() )
IF xParam[ xStack[ 7 ] ] == "Hello"
QOut( ":-)" )
endif
ENDIF
Pause()
return nil
RETURN nil
/* $Doc$
* $FuncName$ <oForm> TForm()
* $Description$ Returns TForm object
* $End$ */
function TForm()
static oClass
FUNCTION TForm()
if oClass == nil
STATIC oClass
IF oClass == nil
oClass := HBClass():New( "TFORM" ) // starts a new class definition
oClass:AddData( "cName" ) // define this class objects datas
@@ -129,129 +129,131 @@ function TForm()
oClass:AddMethod( "Transfer", @Transfer() )
oClass:Create() // builds this class
endif
ENDIF
return oClass:Instance() // builds an object of this class
RETURN oClass:Instance() // builds an object of this class
/* $Doc$
* $FuncName$ <oForm> TForm:New()
* $Description$ Constructor
* $End$ */
static function New()
local Self := QSelf()
STATIC FUNCTION New()
LOCAL Self := QSelf()
::nTop := 10
::nLeft := 10
::nBottom := 20
::nRight := 40
return Self
RETURN Self
/* $Doc$
* $FuncName$ TForm:Show()
* $Description$ Show a form
* $End$ */
static function Show()
local Self := QSelf()
STATIC FUNCTION Show()
LOCAL Self := QSelf()
QOut( "lets show a form from here :-)" )
return nil
RETURN nil
//
// <xRet> TForm:Transfer( [<xArg,..>] )
//
// Generic object import and export function
//
// <xArg> is present.
//
// Maximum number of arguments passed is limited to 10 !
//
// An argument can be one of the following :
//
// { <cSymbol>, <xValue> } Set DATA <cSymbol> to <xValue>
// { { <cSym1>, <xVal1> }, { <cSym2>, <xVal2> }, ... }
// Set a whole list symbols to value
// Normal way of set objects from external
// sources, like memo files.
// <oObject> Set self according to the DATA
// contained in <oObject>
// Can be used to transfer info from
// one class to another
//
// If <xArg> is not present, the current object will be returned as an array
// for description see __objSetValueList / __objGetValueList.
//
// The method aExcept() is called to determine the DATA which should not
// be returned. Eg. hWnd ( do not copy this DATA from external source )
//
// Say we want to copy oSource into oTarget we say :
//
// oTarget:Transfer( oSource )
//
// If we do not want 'cName' duplicated we have to use __objGetValueList :
//
// aNewExcept := aClone( oSource:aExcept() )
// aAdd( aNewExcept, "cName" ) /* Add cName to exception list */
// oTarget:Transfer( __objGetValueList( oSource, aNewExcept ) )
// /* Get DATA from oSource with new exceptions */
// /* Transfer DATA to oTarget */
//
// To set two DATA of oTarget :
//
// oTarget:Transfer( { "nLeft", 10 }, { "nRight", 5 } )
//
// or :
//
// aCollect := {}
// aAdd( aCollect, { "nLeft" , 10 } )
// aAdd( aCollect, { "nRight", 5 } )
// oTarget:Transfer( aCollect )
//
// Copy oSource to a memo field :
//
// DbObject->Memo := oSource:Transfer()
//
// (Re)create oTarget from the memo field :
//
// oTarget := TTarget():New()
// oTarget:Transfer( DbObject->Memo )
//
//
// <xRet> TForm:Transfer( [<xArg,..>] )
//
// Generic object import and export function
//
// <xArg> is present.
//
// Maximum number of arguments passed is limited to 10 !
//
// An argument can be one of the following :
//
// { <cSymbol>, <xValue> } Set DATA <cSymbol> to <xValue>
// { { <cSym1>, <xVal1> }, { <cSym2>, <xVal2> }, ... }
// Set a whole list symbols to value
// Normal way of set objects from external
// sources, like memo files.
// <oObject> Set self according to the DATA
// contained in <oObject>
// Can be used to transfer info from
// one class to another
//
// If <xArg> is not present, the current object will be returned as an array
// for description see __objSetValueList / __objGetValueList.
//
// The method aExcept() is called to determine the DATA which should not
// be returned. Eg. hWnd ( do not copy this DATA from external source )
//
// Say we want to copy oSource into oTarget we say :
//
// oTarget:Transfer( oSource )
//
// If we do not want 'cName' duplicated we have to use __objGetValueList :
//
// aNewExcept := aClone( oSource:aExcept() )
// aAdd( aNewExcept, "cName" ) /* Add cName to exception list */
// oTarget:Transfer( __objGetValueList( oSource, aNewExcept ) )
// /* Get DATA from oSource with new exceptions */
// /* Transfer DATA to oTarget */
//
// To set two DATA of oTarget :
//
// oTarget:Transfer( { "nLeft", 10 }, { "nRight", 5 } )
//
// or :
//
// aCollect := {}
// aAdd( aCollect, { "nLeft" , 10 } )
// aAdd( aCollect, { "nRight", 5 } )
// oTarget:Transfer( aCollect )
//
// Copy oSource to a memo field :
//
// DbObject->Memo := oSource:Transfer()
//
// (Re)create oTarget from the memo field :
//
// oTarget := TTarget():New()
// oTarget:Transfer( DbObject->Memo )
//
static function Transfer( x1,x2,x3,x4,x5,x6,x7,x8,x9,x10 /* etc */ )
STATIC FUNCTION Transfer( x1, x2, x3, x4, x5, x6, x7, x8, x9, x10 ) /* etc */
local self := QSelf()
local aParam := __dbgvmParLList()
local nLen := PCount()
local xRet
local xData
local n
LOCAL self := QSelf()
LOCAL aParam := __dbgVMParLList()
LOCAL nLen := PCount()
LOCAL xRet
LOCAL xData
LOCAL n
if nLen == 0
xRet := __objGetValueList( self, ::aExcept() )
else
for n := 1 to nLen
IF nLen == 0
xRet := __objGetValueLIST( self, ::aExcept() )
ELSE
for n := 1 TO nLen
xData := aParam[ n ]
if ValType( xData ) == "A"
IF ValType( xData ) == "A"
if ValType( xData[1] ) == "A" // 2D array passed
IF ValType( xData[1] ) == "A" // 2D array passed
xRet := __objSetValueList( self, xData )
else // 1D array passed
xRet := __objSetValueList( self, {xData} )
endif
ELSE // 1D array passed
xRet := __objSetValueList( self, { xData } )
ENDIF
elseif ValType( xData ) == "O" // Object passed
ELSEIF ValType( xData ) == "O" // Object passed
xRet := ::Transfer( xData:Transfer() )
elseif ValType( xData ) != "U"
ELSEIF ValType( xData ) != "U"
QOut( "TRANSFER: Incorrect argument(", n, ") ", xData )
endif
ENDIF
next n
endif
ENDIF
return xRet
RETURN xRet

47
harbour/tests/delimtst.prg
View File

@@ -1,50 +1,53 @@
//NOTEST
// $Id$
//
/*
* $Id$
*/
// Test program for COPY TO DELIMITED and APPEND FROM DELIMITED
// Note: Only COPY TO DELIMITED is fully implemented at this time...
// Test program for COPY TO DELIMITED and APPEND FROM DELIMITED
// Note: Only COPY TO DELIMITED is fully implemented at this time...
/* Harbour Project source code
http://harbour-project.org/
Donated to the public domain on 2001-04-18 by David G. Holm <dholm@jsd-llc.com>
*/
procedure main()
local nCount := 0
use test new
PROCEDURE Main()
LOCAL nCount := 0
USE test NEW
// Copy all records and fields.
copy to test1 delimited
COPY TO test1 DELIMITED
// Copy only address fields for records with salary over 50,000.
copy field first,last,street,city,state,zip to test2 delimited for _field->salary>50000
COPY FIELD first, last, street, city, state, zip TO test2 delimited for _field->salary > 50000
// Only copy record 3.
copy record 3 to test3 delimited
COPY RECORD 3 TO test3 DELIMITED
// Copy records 4 through 7.
copy next 4 to test4 delimited
COPY NEXT 4 TO test4 DELIMITED
// Try to copy 10 records, starting 5 records from EOF, using WHILE
go bottom
GO BOTTOM
skip -4
copy while ncount++ < 9 to test4a delimited
COPY WHILE ncount++ < 9 TO test4a DELIMITED
// Copy the last 10 records.
go bottom
GO BOTTOM
skip -9
copy rest to test5 delimited
COPY REST TO test5 DELIMITED
// Copy the last 10 records again.
go bottom
GO BOTTOM
skip -9
copy to test6 delimited while !eof()
COPY TO test6 delimited WHILE ! EOF()
// Copy only some of the last 10 records.
go bottom
GO BOTTOM
skip -9
copy rest to test7 delimited for _field->married
COPY REST TO test7 DELIMITED FOR _field->married
// Try to append from a file that we know does not exist.
delete file test8.txt
append from test8 delimited
quit
DELETE file test8.txt
APPEND FROM test8 delimited
QUIT

36
harbour/tests/devtest.prg
View File

@@ -11,35 +11,37 @@
Public domain program written by David G. Holm <dholm@jsd-llc.com>
*/
procedure main()
PROCEDURE Main()
#ifdef __HARBOUR__
SET PRINTER TO devtesth
#else
SET PRINTER TO devtestc
#endif
SET DEVICE TO PRINTER
DevPos( -2, 76 )
? Prow(), Pcol()
DevPos( - 2, 76 )
? PRow(), PCol()
DevOut( "First text written!" )
? Prow(), Pcol()
? PRow(), PCol()
DevOut( "Hello" )
? Prow(), Pcol()
? PRow(), PCol()
DevPos( 6, 74 )
? Prow(), Pcol()
? PRow(), PCol()
DevOut( "Off to the side!!" )
? Prow(), Pcol()
DevPos( 8, -12 )
? Prow(), Pcol()
DevPos( 13, -12 )
? Prow(), Pcol()
? PRow(), PCol()
DevPos( 8, - 12 )
? PRow(), PCol()
DevPos( 13, - 12 )
? PRow(), PCol()
DevOut( "More test text!" )
? Prow(), Pcol()
? PRow(), PCol()
DevOut( "Yet more text!" )
? Prow(), Pcol()
? PRow(), PCol()
DevPos( 19, 85 )
? Prow(), Pcol()
? PRow(), PCol()
DevPos( 500, 20 )
? Prow(), Pcol()
? PRow(), PCol()
DevOut( "!" )
? Prow(), Pcol()
quit
? PRow(), PCol()
QUIT

71
harbour/tests/disptest.prg
View File

@@ -11,54 +11,57 @@
http://harbour-project.org/
Public domain program written by David G. Holm <dholm@jsd-llc.com>
*/
procedure main()
local a,b,c,d,e,f,g,h,i,j,k,l
SetPos( -2, 76 )
PROCEDURE Main()
LOCAL a, b, c, d, e, f, g, h, i, j, k, l
SetPos( - 2, 76 )
DispOut( "You won't see this!" )
tone(440,1)
inkey(0)
Tone( 440, 1 )
Inkey( 0 )
a := Row()
b := Col()
?? a, b
tone(440,1)
inkey(0)
Tone( 440, 1 )
Inkey( 0 )
c := Row()
d := Col()
?? c, d
tone(440,1)
inkey(0)
Tone( 440, 1 )
Inkey( 0 )
e := Row()
f := Row()
?? e, f
tone(440,1)
inkey(0)
Tone( 440, 1 )
Inkey( 0 )
g := Row()
h := Col()
?? g, h
tone(440,1)
inkey(0)
Tone( 440, 1 )
Inkey( 0 )
i := Row()
j := Col()
?? i, j
tone(440,1)
inkey(0)
Tone( 440, 1 )
Inkey( 0 )
k := Row()
l := Col()
?? k, l
tone(440,1)
inkey(0)
Tone( 440, 1 )
Inkey( 0 )
CLS
?? a,b
?? c,d
?? e,f
?? g,h
?? i,j
?? k,l
?? a, b
?? c, d
?? e, f
?? g, h
?? i, j
?? k, l
DispOut( "Hello" )
SetPos( 6, 74 )
DispOut( "Partly off screen!" )
? Row(), Col()
SetPos( 8, -12 )
SetPos( 8, - 12 )
a := Row()
b := Col()
?? "PA"
@@ -67,10 +70,10 @@ local a,b,c,d,e,f,g,h,i,j,k,l
?? "ll on screen!"
e := Row()
f := Row()
? a,b
? c,d
? e,f
SetPos( 13, -12 )
? a, b
? c, d
? e, f
SetPos( 13, - 12 )
a := Row()
b := Col()
DispOut( "All off screen!" )
@@ -79,13 +82,13 @@ local a,b,c,d,e,f,g,h,i,j,k,l
DispOut( "All on screen!" )
e := Row()
f := Row()
? a,b
? c,d
? e,f
? a, b
? c, d
? e, f
SetPos( 19, 85 )
?? "All on screen??"
tone(880,1)
inkey(0)
Tone( 880, 1 )
Inkey( 0 )
SetPos( 50, 20 )
?? "On screen??"
quit
QUIT

115
harbour/tests/foreach.prg
View File

@@ -1,99 +1,101 @@
/*
* $Id$
*/
PROCEDURE MAIN()
LOCAL A:={ "one ", "two ", "three" }
LOCAL AA:={ "AA-one ", "AA-two ", "AA-three", "AA-four " }
LOCAL c:="abcdefghij"
LOCAL enum:="b"
LOCAL bb, cc
LOCAL i
PROCEDURE Main()
LOCAL A := { "one ", "two ", "three" }
LOCAL AA := { "AA-one ", "AA-two ", "AA-three", "AA-four " }
LOCAL c := "abcdefghij"
LOCAL enum := "b"
LOCAL bb, cc
LOCAL i
/*
test(@a,b)
test(a,@b)
test(@a,@b)
*/
? "========================================================"
? "before loop: ENUM=",ENUM
? 'before loop: a[1]=',a[1], 'a[2]=',a[2], 'a[3]=',a[3]
? "before loop: ENUM=", ENUM
? "before loop: a[1]=", a[1], "a[2]=", a[2], "a[3]=", a[3]
FOR EACH enum IN A
? "start: ENUM=", ENUM
IF ENUM = 'two'
ENUM := UPPER( ENUM )
IF ENUM = "two"
ENUM := Upper( ENUM )
ENDIF
? "end: ENUM=", ENUM, "| index:", ENUM:__enumIndex, "| value:", ENUM:__enumValue, "| base: ", VALTYPE(ENUM:__enumBase)
? "end: ENUM=", ENUM, "| index:", ENUM:__enumIndex, "| value:", ENUM:__enumValue, "| base: ", ValType( ENUM:__enumBase )
NEXT
? "after loop ENUM=", ENUM
? 'after loop: a[1]=',a[1], 'a[2]=',a[2], 'a[3]=',a[3]
? "after loop: a[1]=", a[1], "a[2]=", a[2], "a[3]=", a[3]
? "-----------------"
?
inkey(0)
Inkey( 0 )
? "========================================================"
? "Testing passing by reference"
? "before loop: ENUM=",ENUM
? 'after loop: a[1]=',a[1], 'a[2]=',a[2], 'a[3]=',a[3]
? "before loop: ENUM=", ENUM
? "after loop: a[1]=", a[1], "a[2]=", a[2], "a[3]=", a[3]
FOR EACH ENUM IN A
IF UPPER(ENUM) = 'TWO'
ENUM := UPPER( ENUM )
? "before passing by @ | ENUM=", ENUM, "| index:", ENUM:__enumIndex, "| value:", ENUM:__enumValue, "| base: ", VALTYPE(ENUM:__enumBase)
IF Upper( ENUM ) = "TWO"
ENUM := Upper( ENUM )
? "before passing by @ | ENUM=", ENUM, "| index:", ENUM:__enumIndex, "| value:", ENUM:__enumValue, "| base: ", ValType( ENUM:__enumBase )
testBYREF( @ENUM )
? " after passing by @ | ENUM=", ENUM, "| index:", ENUM:__enumIndex, "| value:", ENUM:__enumValue, "| base: ", VALTYPE(ENUM:__enumBase)
? " after passing by @ | ENUM=", ENUM, "| index:", ENUM:__enumIndex, "| value:", ENUM:__enumValue, "| base: ", ValType( ENUM:__enumBase )
ENDIF
NEXT
? "after loop ENUM=", ENUM
? 'after loop: a[1]=',a[1], 'a[2]=',a[2], 'a[3]=',a[3]
inkey(0)
? "after loop: a[1]=", a[1], "a[2]=", a[2], "a[3]=", a[3]
Inkey( 0 )
? "========================================================"
? "Testing BREAK"
? "before loop: ENUM=",ENUM
? 'after loop: a[1]=',a[1], 'a[2]=',a[2], 'a[3]=',a[3]
? "before loop: ENUM=", ENUM
? "after loop: a[1]=", a[1], "a[2]=", a[2], "a[3]=", a[3]
BEGIN SEQUENCE
FOR EACH enum IN A DESCEND
? "loop: ENUM=", ENUM, "| index:", ENUM:__enumIndex, "| value:", ENUM:__enumValue, "| base: ", VALTYPE(ENUM:__enumBase)
? "loop: ENUM=", ENUM, "| index:", ENUM:__enumIndex, "| value:", ENUM:__enumValue, "| base: ", ValType( ENUM:__enumBase )
TESTbreak( ENUM )
NEXT
RECOVER USING i
? "after loop ENUM=", ENUM
? 'after loop: a[1]=',a[1], 'a[2]=',a[2], 'a[3]=',a[3]
? "after loop: a[1]=", a[1], "a[2]=", a[2], "a[3]=", a[3]
? "recover variable i=", i
END SEQUENCE
inkey(0)
Inkey( 0 )
? "========================================================"
? "before loop: ENUM=",ENUM
? 'before loop: c=',c
? "before loop: ENUM=", ENUM
? "before loop: c=", c
BEGIN SEQUENCE
FOR EACH enum IN c
? "start: ENUM=", ENUM
IF enum = 'd'
enum := UPPER( enum )
IF enum = "d"
enum := Upper( enum )
ENDIF
Testbreak( enum )
? "end: ENUM=", ENUM, "| index:", ENUM:__enumIndex, "| value:", ENUM:__enumValue, "| base: ", VALTYPE(ENUM:__enumBase)
? "end: ENUM=", ENUM, "| index:", ENUM:__enumIndex, "| value:", ENUM:__enumValue, "| base: ", ValType( ENUM:__enumBase )
NEXT
RECOVER USING i
? "after loop ENUM=", ENUM
? 'after loop: c=', c
? "after loop: c=", c
? "recover variable i=", i
END SEQUENCE
? "========================================================"
FOR EACH enum,bb,cc IN A,AA,c
FOR EACH enum, bb, cc IN A, AA, c
? enum, enum:__enumIndex, enum:__enumValue
? bb, bb:__enumIndex, bb:__enumValue
? cc, cc:__enumIndex, cc:__enumValue
NEXT
inkey(0)
Inkey( 0 )
? "========================================================"
FOR EACH enum,bb,cc IN A,AA,c DESCEND
FOR EACH enum, bb, cc IN A, AA, c DESCEND
? enum, enum:__enumIndex, enum:__enumValue
? bb, bb:__enumIndex, bb:__enumValue
? cc, cc:__enumIndex, cc:__enumValue
@@ -101,41 +103,42 @@ LOCAL i
FOR EACH enum IN a
BEGIN SEQUENCE
IF enum = '2'
BREAK
ENDIF
IF enum = "2"
BREAK
ENDIF
END SEQUENCE
NEXT
FOR EACH enum IN a
BEGIN SEQUENCE
IF enum = '2'
? "Breaking... enum=", enum
BREAK enum
ENDIF
IF enum = "2"
? "Breaking... enum=", enum
BREAK enum
ENDIF
RECOVER USING enum
? "after recovery: enum=", enum
END SEQUENCE
NEXT
RETURN
RETURN
PROCEDURE TESTbreak( v )
IF v = '2' .or. v = 'd'
IF v = "2" .OR. v = "d"
? "issuing break"
BREAK( v )
Break( v )
ENDIF
RETURN
RETURN
PROCEDURE TESTBYREF( enum )
? "start of testBYREF ENUM=", ENUM
FOR EACH ENUM IN {1,2,3}
FOR EACH ENUM IN { 1, 2, 3 }
? " -testBYREF=", ENUM
NEXT
? "end of loop: ENUM=", ENUM
ENUM := "22222"
? "end of testBYREF ENUM=", ENUM
RETURN
RETURN

92
harbour/tests/gtstdtst.prg
View File

@@ -1,59 +1,63 @@
//
// $Id$
//
/*
* $Id$
*/
/* gtstd test */
func Main()
local n
PROCEDURE Main()
PosNow()
?? "Output test. First line, no newlines."
LOCAL n
? "Press a key to continue: "
?? inkey(0)
PosNow()
?? "Output test. First line, no newlines."
? "This is row " + alltrim(str(row()))
@ 7, 30 say "@ 7,30"
@ 7, 10 say "@ 7,10"
@ 7, 60 say "@ 7,60"
@ 7, 75 say "9876543210"
@ 6, 10 say "@ 6,10.."
PosNow()
? "Press a key to continue: "
?? Inkey( 0 )
?
? "Scroll test: pre = "
PosNow()
// scroll(0,0,maxrow(),maxcol(),-3,0)
?? " post = "
PosNow()
? "This is row " + AllTrim( Str( Row() ) )
?
? "Press key to test CLS"
inkey(0)
CLS
@ 7, 30 SAY "@ 7,30"
@ 7, 10 SAY "@ 7,10"
@ 7, 60 SAY "@ 7,60"
@ 7, 75 SAY "9876543210"
@ 6, 10 SAY "@ 6,10.."
PosNow()
PosNow()
?
? "Scroll test: pre = "
PosNow()
// Scroll( 0, 0, MaxRow(), MaxCol(), -3, 0 )
?? " post = "
PosNow()
?
? "Press key to test for n := 100 to 120 ; tone(n, 1) ; next"
inkey(0)
for n := 100 to 120 ; tone(n, 1) ; next
?
? "Press key to test CLS"
Inkey( 0 )
CLS
? "Done.."
? "Testing long string via QOUT. 50 characters follow here: 98765432109876543210987654321098765432109876543210"
? "Done.. testing end of screen scroll"
PosNow()
for n := 1 to 25
? "This line is on row "
?? alltrim(str(row()))
inkey(0)
next
?
? "Press key to test for n := 100 to 120 ; tone(n, 1) ; next"
Inkey( 0 )
FOR n := 100 TO 120
Tone( n, 1 )
NEXT
return NIL
? "Done.."
? "Testing long string via QOUT. 50 characters follow here: 98765432109876543210987654321098765432109876543210"
? "Done.. testing end of screen scroll"
func PosNow()
?? "[" + alltrim(str(row())) + "," + alltrim(str(col())) + "]"
return NIL
FOR n := 1 TO 25
? "This line is on row "
?? AllTrim( Str( Row() ) )
Inkey( 0 )
NEXT
RETURN
FUNCTION PosNow()
?? "[" + AllTrim( Str( Row() ) ) + "," + AllTrim( Str( Col() ) ) + "]"
RETURN NIL

2
harbour/tests/ipclnt.prg
View File

@@ -10,7 +10,7 @@
#define PORT 10000
#define EOT ( Chr( 4 ) )
PROCEDURE main()
PROCEDURE Main()
LOCAL hSocket

2
harbour/tests/ipsvr.prg
View File

@@ -13,7 +13,7 @@
REQUEST HB_MT
PROCEDURE main()
PROCEDURE Main()
LOCAL hListen
LOCAL hSocket

53
harbour/tests/langapi.prg
View File

@@ -8,35 +8,34 @@
REQUEST HB_LANG_HU852
REQUEST HB_LANG_KO
func main()
PROCEDURE Main()
? "Prev:", hb_langselect()
? hb_langName()
? NationMsg( 1 )
? CMonth( Date() )
? CDOW( Date() )
? "---------"
? "Prev:", hb_langSelect()
? hb_langName()
? NationMsg( 1 )
? CMonth( Date() )
? CDOW( Date() )
? "---------"
? "Prev:", hb_langSelect( "HU852" )
? hb_langName()
? NationMsg( 1 )
? CMonth( Date() )
? CDOW( Date() )
? "---------"
? "Prev:", hb_langSelect( "HU852" )
? hb_langName()
? NationMsg( 1 )
? CMonth( Date() )
? CDOW( Date() )
? "---------"
? "Prev:", hb_langSelect( "NOTHERE" )
? hb_langName()
? NationMsg( 1 )
? CMonth( Date() )
? CDOW( Date() )
? "---------"
? "Prev:", hb_langSelect( "NOTHERE" )
? hb_langName()
? NationMsg( 1 )
? CMonth( Date() )
? CDOW( Date() )
? "---------"
? "Prev:", hb_langSelect( "KO" )
? hb_langName()
? NationMsg( 1 )
? CMonth( Date() )
? CDOW( Date() )
? "---------"
return nil
? "Prev:", hb_langSelect( "KO" )
? hb_langName()
? NationMsg( 1 )
? CMonth( Date() )
? CDOW( Date() )
? "---------"
RETURN

2
harbour/tests/memtst.prg
View File

@@ -15,7 +15,7 @@
#include "hbmemory.ch"
#endif
proc main()
PROCEDURE Main()
local nCPUSec, nRealSec, i, a
#ifdef __HARBOUR__

455
harbour/tests/memvar.prg
View File

@@ -1,9 +1,10 @@
// Basic test for memvars handling
//
// $Id$
//
/*
* $Id$
*/
MEMVAR memvar
// Basic test for memvars handling
MEMVAR MEMVAR
MEMVAR memvar1
MEMVAR memvar2
MEMVAR memvar3
@@ -28,319 +29,349 @@ MEMVAR param1
MEMVAR param2
MEMVAR initmem
PROCEDURE MAIN()
LOCAL main:=0
PROCEDURE Main()
Test1()
__accept( "press Enter..." )
Test2()
__accept( "press Enter..." )
Test3()
__accept( "press Enter..." )
Test4()
__accept( "press Enter..." )
Test5()
__accept( "press Enter..." )
Test6()
__accept( "press Enter..." )
Test7( 'value1', 2, .T. )
__accept( "press Enter..." )
Test8()
__accept( "press Enter..." )
Test9()
LOCAL main := 0
RETURN
Test1()
__Accept( "press Enter..." )
Test2()
__Accept( "press Enter..." )
Test3()
__Accept( "press Enter..." )
Test4()
__Accept( "press Enter..." )
Test5()
__Accept( "press Enter..." )
Test6()
__Accept( "press Enter..." )
Test7( 'value1', 2, .T. )
__Accept( "press Enter..." )
Test8()
__Accept( "press Enter..." )
Test9()
/////////////////////////////////////////////////////////////////////////
RETURN
/////////////////////////////////////////////////////////////////////////
PROCEDURE Test1()
// PUBLIC overrided by PRIVATE overrided by uninitialized PUBLIC
PUBL memvar1
Qout( "==Test 1==PUBLIC -> PRIVATE -> PUBLIC" )
Qout( memvar1 )
memvar1 ='main'
Qout( 'in MAIN=', memvar1 )
Scope( memvar1 )
Qout( 'back in MAIN=', memvar1 )
Qout( "" )
// PUBLIC overrided by PRIVATE overrided by uninitialized PUBLIC
PUBL memvar1
RETURN
QOut( "==Test 1==PUBLIC -> PRIVATE -> PUBLIC" )
QOut( memvar1 )
memvar1 = 'main'
QOut( 'in MAIN=', memvar1 )
Scope( memvar1 )
QOut( 'back in MAIN=', memvar1 )
QOut( "" )
RETURN
FUNCTION Scope( value )
PRIVA memvar1:='scope'
Scope2()
Qout( "in SCOPE=", memvar1 )
PRIVA memvar1 := 'scope'
RETURN( value )
Scope2()
QOut( "in SCOPE=", memvar1 )
RETURN( value )
PROCEDURE Scope2()
PUBLIC memvar1
Qout( "in SCOPE2=", memvar1 )
RETURN
///////////////////////////////////////////////////////////////////
PUBLIC memvar1
QOut( "in SCOPE2=", memvar1 )
RETURN
///////////////////////////////////////////////////////////////////
PROCEDURE Test2()
// PUBLIC overrided by PUBLIC overrided by uninitialized PUBLIC
PUBLIC memvar2
Qout( "==Test 2==PUBLIC -> PUBLIC -> PUBLIC" )
Qout( memvar2 )
memvar2 ='main'
Qout( 'in MAIN=', memvar2 )
Scope3( memvar2 )
Qout( 'back in MAIN=', memvar2 )
Qout( "" )
// PUBLIC overrided by PUBLIC overrided by uninitialized PUBLIC
PUBLIC memvar2
RETURN
QOut( "==Test 2==PUBLIC -> PUBLIC -> PUBLIC" )
QOut( memvar2 )
memvar2 = 'main'
QOut( 'in MAIN=', memvar2 )
Scope3( memvar2 )
QOut( 'back in MAIN=', memvar2 )
QOut( "" )
RETURN
FUNCTION Scope3( value )
PUBLIC memvar2:='scope'
Scope4()
Qout( "in SCOPE=", memvar2 )
PUBLIC memvar2 := 'scope'
RETURN( value )
Scope4()
QOut( "in SCOPE=", memvar2 )
RETURN( value )
PROCEDURE Scope4()
PUBLIC memvar2
Qout( "in SCOPE2=", memvar2 )
RETURN
////////////////////////////////////////////////////////////////////////////
PUBLIC memvar2
QOut( "in SCOPE2=", memvar2 )
RETURN
////////////////////////////////////////////////////////////////////////////
PROCEDURE Test3()
// PUBLIC overrided by PRIVATE overrided by initialized PUBLIC
PUBLIC memvar3
Qout( "==Test 3==PUBLIC -> PRIVATE -> PUBLIC:=" )
Qout( memvar3 )
memvar3 ='main'
Qout( 'in MAIN=', memvar3 )
Scope5( memvar3 )
Qout( 'back in MAIN=', memvar3 )
Qout( "" )
// PUBLIC overrided by PRIVATE overrided by initialized PUBLIC
PUBLIC memvar3
RETURN
QOut( "==Test 3==PUBLIC -> PRIVATE -> PUBLIC:=" )
QOut( memvar3 )
memvar3 = 'main'
QOut( 'in MAIN=', memvar3 )
Scope5( memvar3 )
QOut( 'back in MAIN=', memvar3 )
QOut( "" )
RETURN
FUNCTION Scope5( value )
PRIVATE memvar3:='scope'
Scope6()
Qout( "in SCOPE=", memvar3 )
PRIVATE memvar3 := 'scope'
RETURN( value )
Scope6()
QOut( "in SCOPE=", memvar3 )
RETURN( value )
PROCEDURE Scope6()
PUBLIC memvar3:='scope2'
Qout( "in SCOPE2=", memvar3 )
RETURN
///////////////////////////////////////////////////////////////////////
PUBLIC memvar3 := 'scope2'
QOut( "in SCOPE2=", memvar3 )
RETURN
///////////////////////////////////////////////////////////////////////
PROCEDURE Test4()
// PUBLIC overrided by PUBLIC overrided by initialized PUBLIC
PUBLIC memvar4
Qout( "==Test 4==PUBLIC -> PUBLIC -> PUBLIC:=" )
Qout( memvar4 )
memvar4 ='main'
Qout( 'in MAIN=', memvar4 )
Scope7( memvar4 )
Qout( 'back in MAIN=', memvar4 )
Qout( "" )
// PUBLIC overrided by PUBLIC overrided by initialized PUBLIC
PUBLIC memvar4
RETURN
QOut( "==Test 4==PUBLIC -> PUBLIC -> PUBLIC:=" )
QOut( memvar4 )
memvar4 = 'main'
QOut( 'in MAIN=', memvar4 )
Scope7( memvar4 )
QOut( 'back in MAIN=', memvar4 )
QOut( "" )
RETURN
FUNCTION Scope7( value )
PUBLIC memvar4:='scope'
Scope8()
Qout( "in SCOPE=", memvar4 )
PUBLIC memvar4 := 'scope'
RETURN( value )
Scope8()
QOut( "in SCOPE=", memvar4 )
RETURN( value )
PROCEDURE Scope8()
PUBLIC memvar4:='scope2'
Qout( "in SCOPE2=", memvar4 )
RETURN
///////////////////////////////////////////////////////////////////////
PUBLIC memvar4 := 'scope2'
QOut( "in SCOPE2=", memvar4 )
RETURN
///////////////////////////////////////////////////////////////////////
PROCEDURE TEST5()
PUBLIC mempublic, public3:=3
//PUBLIC public2[ 10 ] //unsupported yet
PRIVATE memprivate
PARAMETERS memparam
Qout( "==Test for memvars passed by reference and __PUBLIC/__PRIVATE " )
Qout( " uninitialized PUBLIC= ", mempublic )
// Qout( "uninitialized PUBLIC array (first item)=", public2[1] )
Qout( "initialized PUBLIC= ", public3 )
Qout( " uninitialized PRIVATE= ", memprivate )
Qout( "uninitialized PARAMETER= ", memparam )
// Qout( memnone )
PUBLIC mempublic, public3 := 3
mempublic ='PUBLIC'
Qout( " PUBLIC with new value= ", mempublic )
memprivate ='PRIVATE'
Qout( " PRIVATE with new value= ", memprivate )
memparam ='PARAMETER'
Qout( "PARAMETER with new value= ", memparam )
// memnone =4
// Qout( memnone )
// PUBLIC public2[ 10 ] //unsupported yet
PRIVATE memprivate
PARAMETERS memparam
Qout( " PUBLIC after passing by reference= ", UseVar( @mempublic ) )
Qout( " PRIVATE after passing by reference= ", UseVar( @memprivate ) )
Qout( "PARAMETER after passing by reference= ", UseVar( @memparam ) )
// Qout( Use( @memnone ) )
QOut( "==Test for memvars passed by reference and __PUBLIC/__PRIVATE " )
QOut( " uninitialized PUBLIC= ", mempublic )
// QOut( "uninitialized PUBLIC array (first item)=", public2[1] )
QOut( "initialized PUBLIC= ", public3 )
QOut( " uninitialized PRIVATE= ", memprivate )
QOut( "uninitialized PARAMETER= ", memparam )
// QOut( memnone )
mempublic = 'PUBLIC'
QOut( " PUBLIC with new value= ", mempublic )
memprivate = 'PRIVATE'
QOut( " PRIVATE with new value= ", memprivate )
memparam = 'PARAMETER'
QOut( "PARAMETER with new value= ", memparam )
// memnone =4
// Qout( memnone )
QOut( " PUBLIC after passing by reference= ", UseVar( @mempublic ) )
QOut( " PRIVATE after passing by reference= ", UseVar( @memprivate ) )
QOut( "PARAMETER after passing by reference= ", UseVar( @memparam ) )
// Qout( Use( @memnone ) )
#ifdef __HARBOUR__
Qout( "PUBLIC created by __PUBLIC function=", public1 )
QOut( "PUBLIC created by __PUBLIC function=", public1 )
#endif
Qout( "" )
RETURN
QOut( "" )
RETURN
FUNCTION UseVar( value )
UseRef( @value )
UseRef( @value )
#ifdef __HARBOUR__
__mvPUBLIC( "public1" ) //, "public21" )
// __mvPRIVATE( "private1", "private2", "private3" )
__mvPRIVATE( {"private1", "private2", "private3"} )
Qout( "undeclared PUBLIC created by __PUBLIC function=", public1 )
Qout( "undeclared PRIVATE created by __PRIVATE function=", private1 )
Qout( "undeclared PRIVATE created by __PRIVATE function=", private2 )
Qout( "undeclared PRIVATE created by __PRIVATE function=", private3 )
__mvPublic( "public1" ) //, "public21" )
// __mvPRIVATE( "private1", "private2", "private3" )
__mvPrivate( { "private1", "private2", "private3" } )
QOut( "undeclared PUBLIC created by __PUBLIC function=", public1 )
QOut( "undeclared PRIVATE created by __PRIVATE function=", private1 )
QOut( "undeclared PRIVATE created by __PRIVATE function=", private2 )
QOut( "undeclared PRIVATE created by __PRIVATE function=", private3 )
public1 :='public created by __PUBLIC'
public1 := 'public created by __PUBLIC'
#endif
Qout( "" )
QOut( "" )
RETURN( value )
RETURN( value )
PROCEDURE UseRef( reference )
reference +=' variable'
reference += ' variable'
RETURN
RETURN
//////////////////////////////////////////////////////////////////////
//////////////////////////////////////////////////////////////////////
PROCEDURE Test6()
PUBLIC publCB
PRIVATE privVar:=' (PRIVATE in MAIN) '
Qout( "== Test for detached PRIVATE variables" )
DetachMemvar( 'detached memvar' )
Qout( EVAL( publCB, 'in Main: ' ) )
PUBLIC publCB
PRIVATE privVar := ' (PRIVATE in MAIN) '
RETURN
QOut( "== Test for detached PRIVATE variables" )
DetachMemvar( 'detached memvar' )
QOut( Eval( publCB, 'in Main: ' ) )
RETURN
PROCEDURE DetachMemvar( cValue )
PRIVATE privVar:=' (PRIVATE in DetachMemvar) '
publCB ={|x| x+privVar+cValue}
Qout( EVAL( publCB, "in DetachMemvar: " ) )
PRIVATE privVar := ' (PRIVATE in DetachMemvar) '
RETURN
publCB = {| x | x + privVar + cValue }
QOut( Eval( publCB, "in DetachMemvar: " ) )
////////////////////////////////////////////////////////////////////////
RETURN
////////////////////////////////////////////////////////////////////////
PROCEDURE Test7( )
PARAMETERS para1, para2, para3
PARAM parameter1again
Qout( "Parameter 1 =", para1 )
Qout( "Parameter 2 =", para2 )
Qout( "Parameter 3 =", para3 )
Qout( "Parameter 4 =", parameter1again )
PARAMETERS para1, para2, para3
PARAM parameter1again
RETURN
QOut( "Parameter 1 =", para1 )
QOut( "Parameter 2 =", para2 )
QOut( "Parameter 3 =", para3 )
QOut( "Parameter 4 =", parameter1again )
/////////////////////////////////////////////////////////////////////////
RETURN
/////////////////////////////////////////////////////////////////////////
PROCEDURE Test8()
PRIVATE private1:='PRIVATE1'
Qout( 'In Test8 before UsePriv' )
Qout( "Private1 = ", private1 )
UsePriv( private1 )
Qout( 'In Test8 after UsePriv' )
Qout( "Private1 = ", private1 )
PRIVATE private1 := 'PRIVATE1'
__accept( "press Enter..." )
QOut( 'In Test8 before UsePriv' )
QOut( "Private1 = ", private1 )
UsePriv( private1 )
QOut( 'In Test8 after UsePriv' )
QOut( "Private1 = ", private1 )
Qout( 'In Test8 before UsePriv with reference' )
Qout( "Private1 = ", private1 )
UsePriv( @private1 )
Qout( 'In Test8 after UsePriv with reference' )
Qout( "Private1 = ", private1 )
__Accept( "press Enter..." )
QOut( 'In Test8 before UsePriv with reference' )
QOut( "Private1 = ", private1 )
UsePriv( @private1 )
QOut( 'In Test8 after UsePriv with reference' )
QOut( "Private1 = ", private1 )
RETURN
RETURN
PROCEDURE UsePriv()
PARAMETERS param1
Qout( 'In UsePriv before UseParam' )
Qout( "Private1 = ", private1 )
Qout( "Param1 = ", param1 )
UseParam()
Qout( 'In UsePriv after UseParam' )
Qout( "Private1 = ", private1 )
Qout( "Param1 = ", param1 )
PARAMETERS param1
RETURN
QOut( 'In UsePriv before UseParam' )
QOut( "Private1 = ", private1 )
QOut( "Param1 = ", param1 )
UseParam()
QOut( 'In UsePriv after UseParam' )
QOut( "Private1 = ", private1 )
QOut( "Param1 = ", param1 )
RETURN
PROCEDURE UseParam()
PARAMETER param2
Qout( 'In UseParam before assignment' )
Qout( "Private1 = ", private1 )
Qout( "Param1 = ", param1 )
Qout( "Param2 = ", param2 )
param2 :='PARAM2'
param1 :="new value"
Qout( 'In UseParam after assignment' )
Qout( "Private1 = ", private1 )
Qout( "Param1 = ", param1 )
Qout( "Param2 = ", param2 )
PARAMETER param2
RETURN
QOut( 'In UseParam before assignment' )
QOut( "Private1 = ", private1 )
QOut( "Param1 = ", param1 )
QOut( "Param2 = ", param2 )
param2 := 'PARAM2'
param1 := "new value"
QOut( 'In UseParam after assignment' )
QOut( "Private1 = ", private1 )
QOut( "Param1 = ", param1 )
QOut( "Param2 = ", param2 )
//////////////////////////////////////////////////////////////////////
RETURN
//////////////////////////////////////////////////////////////////////
PROCEDURE TEST9()
PUBLIC memvar
PUBLIC memfunc
memvar :=19
Qout( "Variable with the name of module (memvar)=", memvar )
PUBLIC MEMVAR
PUBLIC memfunc
memfunc := 33
Qout( "Variable with the name of function =", memfunc )
Qout( "Return value from a function=", memfunc( 9 ) )
memvar := 19
// mem()
QOut( "Variable with the name of module (memvar)=", memvar )
RETURN
memfunc := 33
QOut( "Variable with the name of function =", memfunc )
QOut( "Return value from a function=", memfunc( 9 ) )
// mem()
RETURN
STATIC FUNCTION memfunc( memfunc )
RETURN memfunc * memfunc
RETURN memfunc * memfunc
INIT PROCEDURE initmem()
PARA memvar
PARA initmem
Qout( "Tests for PARAMETERS, PRIVATE nad PUBLIC variables" )
Qout( "" )
Qout( 'in INIT function - Passed parameter = ', memvar )
Qout( 'in INIT function - Passed parameter with different name = ', initmem )
Qout( "" )
RETURN
INIT PROCEDURE initmem()
PARA MEMVAR
PARA initmem
QOut( "Tests for PARAMETERS, PRIVATE nad PUBLIC variables" )
QOut( "" )
QOut( 'in INIT function - Passed parameter = ', memvar )
QOut( 'in INIT function - Passed parameter with different name = ', initmem )
QOut( "" )
RETURN

82
harbour/tests/menutest.prg
View File

@@ -1,70 +1,70 @@
//
// $Id$
//
/*
* $Id$
*/
#include "inkey.ch"
procedure main()
PROCEDURE Main()
memvar ptestvar
MEMVAR ptestvar
local testvar
LOCAL testvar
set key K_F8 to RECURSE()
SET KEY K_F8 TO RECURSE()
clear screen
CLEAR SCREEN
@ 1, 10 prompt 'Menu Item 1' message 'Menu Message 1'
@ 2, 10 prompt 'Menu Item 2' message 'Menu Message 2'
@ 3, 10 prompt 'Menu Item 3' message 'Menu Message 3'
@ 4, 10 prompt 'Menu Item 4' message 'Menu Message 4'
@ 1, 10 PROMPT 'Menu Item 1' MESSAGE 'Menu Message 1'
@ 2, 10 PROMPT 'Menu Item 2' MESSAGE 'Menu Message 2'
@ 3, 10 PROMPT 'Menu Item 3' MESSAGE 'Menu Message 3'
@ 4, 10 PROMPT 'Menu Item 4' MESSAGE 'Menu Message 4'
@ 6, 10 say 'Testing with LOCAL parameter'
@ 7, 10 say 'Press F8 to recurse into MENU TO'
@ 6, 10 SAY 'Testing with LOCAL parameter'
@ 7, 10 SAY 'Press F8 to recurse into MENU TO'
menu to testvar
MENU TO testvar
@ 9, 10 say 'Your Choice = ' + str( testvar, 1 )
@ 9, 10 SAY 'Your Choice = ' + Str( testvar, 1 )
Inkey(0)
Inkey( 0 )
set key K_F8 to RECURSE()
SET KEY K_F8 TO RECURSE()
clear screen
CLEAR SCREEN
@ 1, 10 prompt 'Menu Item 1' message 'Menu Message 1'
@ 2, 10 prompt 'Menu Item 2' message 'Menu Message 2'
@ 3, 10 prompt 'Menu Item 3' message 'Menu Message 3'
@ 4, 10 prompt 'Menu Item 4' message 'Menu Message 4'
@ 1, 10 PROMPT 'Menu Item 1' MESSAGE 'Menu Message 1'
@ 2, 10 PROMPT 'Menu Item 2' MESSAGE 'Menu Message 2'
@ 3, 10 PROMPT 'Menu Item 3' MESSAGE 'Menu Message 3'
@ 4, 10 PROMPT 'Menu Item 4' MESSAGE 'Menu Message 4'
@ 6, 10 say 'Testing with MEMVAR parameter'
@ 7, 10 say 'Press F8 to recurse into MENU TO'
@ 6, 10 SAY 'Testing with MEMVAR parameter'
@ 7, 10 SAY 'Press F8 to recurse into MENU TO'
menu to ptestvar
MENU TO ptestvar
@ 9, 10 say 'Your Choice = ' + str( ptestvar, 1 )
@ 9, 10 SAY 'Your Choice = ' + Str( ptestvar, 1 )
return
RETURN
procedure RECURSE()
PROCEDURE RECURSE()
local testvar
LOCAL testvar
set key K_F8 to
SET KEY K_F8 TO
@ 6, 10 say ' '
@ 6, 10 SAY ' '
@ 1, 50 prompt 'Menu Item 1' message 'Menu Message 1'
@ 2, 50 prompt 'Menu Item 2' message 'Menu Message 2'
@ 3, 50 prompt 'Menu Item 3' message 'Menu Message 3'
@ 4, 50 prompt 'Menu Item 4' message 'Menu Message 4'
@ 1, 50 PROMPT 'Menu Item 1' MESSAGE 'Menu Message 1'
@ 2, 50 PROMPT 'Menu Item 2' MESSAGE 'Menu Message 2'
@ 3, 50 PROMPT 'Menu Item 3' MESSAGE 'Menu Message 3'
@ 4, 50 PROMPT 'Menu Item 4' MESSAGE 'Menu Message 4'
menu to testvar
MENU TO testvar
@ 7, 10 say 'Press F8 to recurse into MENU TO'
@ 7, 10 SAY 'Press F8 to recurse into MENU TO'
@ 9, 50 say 'Your Choice = ' + str( testvar, 1 )
@ 9, 50 SAY 'Your Choice = ' + Str( testvar, 1 )
set key K_F8 to RECURSE()
SET KEY K_F8 TO RECURSE()
return
RETURN

2
harbour/tests/mousetst.prg
View File

@@ -10,7 +10,7 @@
#include "inkey.ch"
PROCEDURE main()
PROCEDURE Main()
LOCAL nR := 5, nC := 38

21
harbour/tests/multiarg.prg
View File

@@ -1,10 +1,7 @@
//
// $Id$
//
/*
* $Id$
*/
//
// MultiArg
//
// Testing of multiple arguments
//
// Date : 1999/05/24
@@ -14,17 +11,19 @@
//
// Placed in the public domain
//
function Main()
PROCEDURE Main()
ShoutArg( 1, "1", 2.5, .T. )
ShoutArg( 2, "1", 2.5, .T. )
ShoutArg( 3, "1", 2.5, .T. )
ShoutArg( 4, "1", 2.5, .T. )
ShoutArg( 5, "1", 2.5, .T. )
return nil
RETURN
function ShoutArg( nArg, x1,x2,x3,x4,x5,x6,x7,x8,x9,x10 )
FUNCTION ShoutArg( nArg, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10 )
QOut( nArg, "==", HB_PValue( nArg ) )
return nil
QOut( nArg, "==", hb_PValue( nArg ) )
RETURN nil

233
harbour/tests/newrdd.prg
View File

@@ -1,18 +1,19 @@
//
// $Id$
//
/*
* $Id$
*/
function Main()
PROCEDURE Main()
local nI, aArray
LOCAL nI, aArray
REQUEST _DBF
rddSetDefault( "DBF" )
SET EXCLUSIVE OFF
CLS
dbUseArea( .T., "DBF", "test", "TESTDBF", .T., .F. )
dbUseArea( .T. , "DBF", "test", "TESTDBF", .T. , .F. )
? "RecCount:", TESTDBF->( RecCount() )
? "Used:", TESTDBF->( Used() )
? "Select:", TESTDBF->( Select() )
@@ -21,16 +22,16 @@ function Main()
? "NetErr:", TESTDBF->( NetErr() )
? "Press any key to continue..."
InKey( 0 )
Inkey( 0 )
CLS
aArray := RddList( 0 )
aArray := rddList( 0 )
? "Rdd's: "
for nI := 1 to Len( aArray )
FOR nI := 1 TO Len( aArray )
?? aArray[ nI ], ""
next
? "RddName:", TESTDBF->( RddName() )
? "lUpdate:", TESTDBF->( lUpdate() )
NEXT
? "RddName:", TESTDBF->( rddName() )
? "lUpdate:", TESTDBF->( LUpdate() )
? "Header:", TESTDBF->( Header() )
? "FieldPos( 'LAST' ):", TESTDBF->( FieldPos( "LAST" ) )
? "FieldName( 2 ):", TESTDBF->( FieldName( 2 ) )
@@ -39,109 +40,109 @@ function Main()
? "dbTableExt():", TESTDBF->( dbTableExt() )
aArray := TESTDBF->( dbStruct() )
? "dbStruct:"
for nI := 1 to Len( aArray )
FOR nI := 1 TO Len( aArray )
? PadR( aArray[ nI ][ 1 ], 10 ) , aArray[ nI ][ 2 ], aArray[ nI ][ 3 ], aArray[ nI ][ 4 ]
next
NEXT
? "Press any key to continue..."
InKey( 0 )
Inkey( 0 )
CLS
? "dbGoTop():"
dbGoTop()
? "Bof Eof Found Deleted RecNo:", TESTDBF->( Bof() ), TESTDBF->( Eof() ), ;
TESTDBF->( Found() ), TESTDBF->( Deleted() ), TESTDBF->( Deleted() ), ;
TESTDBF->( RecNo() )
? "Bof Eof Found Deleted RecNo:", TESTDBF->( BOF() ), TESTDBF->( EOF() ), ;
TESTDBF->( Found() ), TESTDBF->( Deleted() ), TESTDBF->( Deleted() ), ;
TESTDBF->( RecNo() )
? "dbSkip( -1 ):"
dbSkip( -1 )
? "Bof Eof Found Deleted RecNo:", TESTDBF->( Bof() ), TESTDBF->( Eof() ), ;
TESTDBF->( Found() ), TESTDBF->( Deleted() ), TESTDBF->( Deleted() ), ;
TESTDBF->( RecNo() )
dbSkip( - 1 )
? "Bof Eof Found Deleted RecNo:", TESTDBF->( BOF() ), TESTDBF->( EOF() ), ;
TESTDBF->( Found() ), TESTDBF->( Deleted() ), TESTDBF->( Deleted() ), ;
TESTDBF->( RecNo() )
? "dbSkip( -1 ):"
dbSkip( -1 )
? "Bof Eof Found Deleted RecNo:", TESTDBF->( Bof() ), TESTDBF->( Eof() ), ;
TESTDBF->( Found() ), TESTDBF->( Deleted() ), TESTDBF->( Deleted() ), ;
TESTDBF->( RecNo() )
dbSkip( - 1 )
? "Bof Eof Found Deleted RecNo:", TESTDBF->( BOF() ), TESTDBF->( EOF() ), ;
TESTDBF->( Found() ), TESTDBF->( Deleted() ), TESTDBF->( Deleted() ), ;
TESTDBF->( RecNo() )
? "dbSkip( 1 ):"
dbSkip( 1 )
? "Bof Eof Found Deleted RecNo:", TESTDBF->( Bof() ), TESTDBF->( Eof() ), ;
TESTDBF->( Found() ), TESTDBF->( Deleted() ), TESTDBF->( Deleted() ), ;
TESTDBF->( RecNo() )
? "Bof Eof Found Deleted RecNo:", TESTDBF->( BOF() ), TESTDBF->( EOF() ), ;
TESTDBF->( Found() ), TESTDBF->( Deleted() ), TESTDBF->( Deleted() ), ;
TESTDBF->( RecNo() )
? "dbSkip( 1 ):"
dbSkip( 1 )
? "Bof Eof Found Deleted RecNo:", TESTDBF->( Bof() ), TESTDBF->( Eof() ), ;
TESTDBF->( Found() ), TESTDBF->( Deleted() ), TESTDBF->( Deleted() ), ;
TESTDBF->( RecNo() )
? "Bof Eof Found Deleted RecNo:", TESTDBF->( BOF() ), TESTDBF->( EOF() ), ;
TESTDBF->( Found() ), TESTDBF->( Deleted() ), TESTDBF->( Deleted() ), ;
TESTDBF->( RecNo() )
? "dbGoTop():"
dbGoTop()
? "Bof Eof Found Deleted RecNo:", TESTDBF->( Bof() ), TESTDBF->( Eof() ), ;
TESTDBF->( Found() ), TESTDBF->( Deleted() ), TESTDBF->( Deleted() ), ;
TESTDBF->( RecNo() )
? "Bof Eof Found Deleted RecNo:", TESTDBF->( BOF() ), TESTDBF->( EOF() ), ;
TESTDBF->( Found() ), TESTDBF->( Deleted() ), TESTDBF->( Deleted() ), ;
TESTDBF->( RecNo() )
? "dbSkip( 1 ):"
dbSkip( 1 )
? "Bof Eof Found Deleted RecNo:", TESTDBF->( Bof() ), TESTDBF->( Eof() ), ;
TESTDBF->( Found() ), TESTDBF->( Deleted() ), TESTDBF->( Deleted() ), ;
TESTDBF->( RecNo() )
? "Bof Eof Found Deleted RecNo:", TESTDBF->( BOF() ), TESTDBF->( EOF() ), ;
TESTDBF->( Found() ), TESTDBF->( Deleted() ), TESTDBF->( Deleted() ), ;
TESTDBF->( RecNo() )
? "dbSkip( 1 ):"
dbSkip( 1 )
? "Bof Eof Found Deleted RecNo:", TESTDBF->( Bof() ), TESTDBF->( Eof() ), ;
TESTDBF->( Found() ), TESTDBF->( Deleted() ), TESTDBF->( Deleted() ), ;
TESTDBF->( RecNo() )
? "Bof Eof Found Deleted RecNo:", TESTDBF->( BOF() ), TESTDBF->( EOF() ), ;
TESTDBF->( Found() ), TESTDBF->( Deleted() ), TESTDBF->( Deleted() ), ;
TESTDBF->( RecNo() )
? "dbSkip( -1 ):"
dbSkip( -1 )
? "Bof Eof Found Deleted RecNo:", TESTDBF->( Bof() ), TESTDBF->( Eof() ), ;
TESTDBF->( Found() ), TESTDBF->( Deleted() ), TESTDBF->( Deleted() ), ;
TESTDBF->( RecNo() )
dbSkip( - 1 )
? "Bof Eof Found Deleted RecNo:", TESTDBF->( BOF() ), TESTDBF->( EOF() ), ;
TESTDBF->( Found() ), TESTDBF->( Deleted() ), TESTDBF->( Deleted() ), ;
TESTDBF->( RecNo() )
? "dbSkip( -1 ):"
dbSkip( -1 )
? "Bof Eof Found Deleted RecNo:", TESTDBF->( Bof() ), TESTDBF->( Eof() ), ;
TESTDBF->( Found() ), TESTDBF->( Deleted() ), TESTDBF->( Deleted() ), ;
TESTDBF->( RecNo() )
InKey( 0 )
dbSkip( - 1 )
? "Bof Eof Found Deleted RecNo:", TESTDBF->( BOF() ), TESTDBF->( EOF() ), ;
TESTDBF->( Found() ), TESTDBF->( Deleted() ), TESTDBF->( Deleted() ), ;
TESTDBF->( RecNo() )
Inkey( 0 )
CLS
? "dbGoBottom():"
dbGoBottom()
? "Bof Eof Found Deleted RecNo:", TESTDBF->( Bof() ), TESTDBF->( Eof() ), ;
TESTDBF->( Found() ), TESTDBF->( Deleted() ), TESTDBF->( Deleted() ), ;
TESTDBF->( RecNo() )
? "Bof Eof Found Deleted RecNo:", TESTDBF->( BOF() ), TESTDBF->( EOF() ), ;
TESTDBF->( Found() ), TESTDBF->( Deleted() ), TESTDBF->( Deleted() ), ;
TESTDBF->( RecNo() )
? "dbSkip( 1 ):"
dbSkip( 1 )
? "Bof Eof Found Deleted RecNo:", TESTDBF->( Bof() ), TESTDBF->( Eof() ), ;
TESTDBF->( Found() ), TESTDBF->( Deleted() ), TESTDBF->( Deleted() ), ;
TESTDBF->( RecNo() )
? "Bof Eof Found Deleted RecNo:", TESTDBF->( BOF() ), TESTDBF->( EOF() ), ;
TESTDBF->( Found() ), TESTDBF->( Deleted() ), TESTDBF->( Deleted() ), ;
TESTDBF->( RecNo() )
? "dbSkip( 1 ):"
dbSkip( 1 )
? "Bof Eof Found Deleted RecNo:", TESTDBF->( Bof() ), TESTDBF->( Eof() ), ;
TESTDBF->( Found() ), TESTDBF->( Deleted() ), TESTDBF->( Deleted() ), ;
TESTDBF->( RecNo() )
? "Bof Eof Found Deleted RecNo:", TESTDBF->( BOF() ), TESTDBF->( EOF() ), ;
TESTDBF->( Found() ), TESTDBF->( Deleted() ), TESTDBF->( Deleted() ), ;
TESTDBF->( RecNo() )
? "dbSkip( -1 ):"
dbSkip( -1 )
? "Bof Eof Found Deleted RecNo:", TESTDBF->( Bof() ), TESTDBF->( Eof() ), ;
TESTDBF->( Found() ), TESTDBF->( Deleted() ), TESTDBF->( Deleted() ), ;
TESTDBF->( RecNo() )
dbSkip( - 1 )
? "Bof Eof Found Deleted RecNo:", TESTDBF->( BOF() ), TESTDBF->( EOF() ), ;
TESTDBF->( Found() ), TESTDBF->( Deleted() ), TESTDBF->( Deleted() ), ;
TESTDBF->( RecNo() )
? "dbSkip( -1 ):"
dbSkip( -1 )
? "Bof Eof Found Deleted RecNo:", TESTDBF->( Bof() ), TESTDBF->( Eof() ), ;
TESTDBF->( Found() ), TESTDBF->( Deleted() ), TESTDBF->( Deleted() ), ;
TESTDBF->( RecNo() )
dbSkip( - 1 )
? "Bof Eof Found Deleted RecNo:", TESTDBF->( BOF() ), TESTDBF->( EOF() ), ;
TESTDBF->( Found() ), TESTDBF->( Deleted() ), TESTDBF->( Deleted() ), ;
TESTDBF->( RecNo() )
? "Press any key to continue..."
InKey( 0 )
Inkey( 0 )
CLS
? "dbGoto( 490 ):"
dbGoto( 490 )
? "Bof Eof Found Deleted RecNo:", TESTDBF->( Bof() ), TESTDBF->( Eof() ), ;
TESTDBF->( Found() ), TESTDBF->( Deleted() ), TESTDBF->( Deleted() ), ;
TESTDBF->( RecNo() )
? "Bof Eof Found Deleted RecNo:", TESTDBF->( BOF() ), TESTDBF->( EOF() ), ;
TESTDBF->( Found() ), TESTDBF->( Deleted() ), TESTDBF->( Deleted() ), ;
TESTDBF->( RecNo() )
? "FCount:", TESTDBF->( FCount() )
for nI := 1 to TESTDBF->( FCount() )
FOR nI := 1 TO TESTDBF->( FCount() )
? "FieldGet( " + LTrim( Str( nI ) ) + " ):", TESTDBF->( FieldGet( nI ) )
next
NEXT
? "Press any key to continue..."
InKey( 0 )
Inkey( 0 )
CLS
? "while !TESTDBF->( Eof() )"
@@ -149,13 +150,13 @@ function Main()
? " TESTDBF->( dbSkip() )"
? "end"
? ""
while !TESTDBF->( Eof() )
WHILE !TESTDBF->( EOF() )
? TESTDBF->FIRST, TESTDBF->( RecNo() )
TESTDBF->( dbSkip() )
end
ENDDO
? "Press any key to continue..."
InKey( 0 )
Inkey( 0 )
CLS
? "SET FILTER TO TESTDBF->AGE == 21"
@@ -164,20 +165,20 @@ function Main()
? "while !TESTDBF->( Eof() )"
? " ? TESTDBF->FIRST, TESTDBF->AGE, TESTDBF->( RecNo() )"
? " TESTDBF->( dbSkip() )"
? "end"
? "enddo"
? "SET FILTER TO"
? ""
SET FILTER TO TESTDBF->AGE == 21
? TESTDBF->( dbFilter() )
TESTDBF->( dbGoTop() )
while !TESTDBF->( Eof() )
WHILE !TESTDBF->( EOF() )
? TESTDBF->FIRST, TESTDBF->AGE, TESTDBF->( RecNo() )
TESTDBF->( dbSkip() )
end
ENDDO
SET FILTER TO
? "Press any key to continue..."
InKey( 0 )
Inkey( 0 )
CLS
? "TESTDBF->( Found() )"
@@ -188,13 +189,13 @@ function Main()
? "end"
TESTDBF->( Found() )
LOCATE FOR TESTDBF->AGE == 23
while TESTDBF->( Found() )
WHILE TESTDBF->( Found() )
? TESTDBF->FIRST, TESTDBF->AGE, TESTDBF->( RecNo() )
CONTINUE
end
ENDDO
? "Press any key to continue..."
InKey( 0 )
Inkey( 0 )
CLS
? "TESTDBF->( dbEval( { || QOut( TESTDBF->FIRST, TESTDBF->AGE ) }, ;"
@@ -202,11 +203,11 @@ function Main()
? ""
? "dbCommit()"
TESTDBF->( dbEval( { || QOut( TESTDBF->FIRST, TESTDBF->AGE ) }, ;
{ || TESTDBF->AGE == 23 } ) )
{ || TESTDBF->AGE == 23 } ) )
TESTDBF->( dbCommit() )
? "Press any key to continue..."
InKey( 0 )
Inkey( 0 )
CLS
? 'dbCreate( "newrdd", { { "First_Name", "C", 20, 0 }, ;'
@@ -217,16 +218,16 @@ function Main()
? ' { "Student", "L", 1, 0 } },, .T., "newrdd" )'
? 'SET CENTURY ON'
dbCreate( "newrdd", { { "First_Name", "C", 20, 0 }, ;
{ "Age", "N", 3, 0 }, ;
{ "Date", "D", 8, 0 }, ;
{ "Rate", "N", 6, 2 }, ;
{ "Memo", "M", 10, 0 }, ;
{ "Student", "L", 1, 0 } },, .T., "newrdd" )
{ "Age", "N", 3, 0 }, ;
{ "Date", "D", 8, 0 }, ;
{ "Rate", "N", 6, 2 }, ;
{ "Memo", "M", 10, 0 }, ;
{ "Student", "L", 1, 0 } }, , .T. , "newrdd" )
SET CENTURY ON
? "lUpdate:", NEWRDD->( lUpdate() )
? "lUpdate:", NEWRDD->( LUpdate() )
? "Press any key to continue..."
InKey( 0 )
Inkey( 0 )
CLS
? 'Select( "TESTDBF" )'
@@ -255,21 +256,21 @@ function Main()
? "NEWRDD->( dbDelete() )"
? "? NEWRDD->( Deleted() )"
? "NEWRDD->( dbRLock( 3 ) )"
Select( "TESTDBF" )
SELECT( "TESTDBF" )
SET FILTER TO TESTDBF->SALARY > 120000
TESTDBF->( dbGoTop() )
while !TESTDBF->( Eof() )
WHILE !TESTDBF->( EOF() )
NEWRDD->( dbAppend() )
NEWRDD->FIRST_NAME := TESTDBF->FIRST
NEWRDD->AGE := TESTDBF->AGE
NEWRDD->DATE := TESTDBF->HIREDATE
NEWRDD->RATE := Val( Right( LTrim( Str( Seconds() ) ), 5 ) )
NEWRDD->MEMO := TESTDBF->FIRST + Chr( 13 ) + Chr( 10 ) + ;
TESTDBF->LAST + Chr( 13 ) + Chr( 10 ) + ;
TESTDBF->STREET
TESTDBF->LAST + Chr( 13 ) + Chr( 10 ) + ;
TESTDBF->STREET
NEWRDD->STUDENT := TESTDBF->MARRIED
TESTDBF->( dbSkip() )
end
ENDDO
SET FILTER TO
? NEWRDD->( RecCount() )
NEWRDD->( dbGoTop() )
@@ -283,7 +284,7 @@ function Main()
NEWRDD->( dbRLock( 3 ) )
? "Press any key to continue..."
InKey( 0 )
Inkey( 0 )
CLS
aArray := NEWRDD->( dbRLockList() )
@@ -292,12 +293,12 @@ function Main()
? " ? aArray[ nI ]"
? "next"
? "dbRLockList(): "
for nI := 1 to Len( aArray )
FOR nI := 1 TO Len( aArray )
? aArray[ nI ]
next
NEXT
? "Press any key to continue..."
InKey( 0 )
Inkey( 0 )
CLS
? 'NEWRDD->( dbCloseArea() )'
@@ -307,18 +308,18 @@ function Main()
? '? "RecCount:", NEWRDD->( RecCount() )'
? ""
NEWRDD->( dbCloseArea() )
dbUseArea( .T., "DBF", "newrdd", "NEWRDD", .F., .F. )
dbUseArea( .T. , "DBF", "newrdd", "NEWRDD", .F. , .F. )
? "Press any key to continue..."
InKey( 0 )
Inkey( 0 )
CLS
nI := 1
NEWRDD->( __dbPack( { || QOut( nI ), nI++ } ) )
NEWRDD->( __dbPack( { || QOut( nI ), nI ++ } ) )
? "RecCount:", NEWRDD->( RecCount() )
? "Press any key to continue..."
InKey( 0 )
Inkey( 0 )
CLS
? '? "RecCount:", NEWRDD->( RecCount() )'
@@ -330,7 +331,7 @@ function Main()
? "RecCount:", NEWRDD->( RecCount() )
? "Press any key to continue..."
InKey( 0 )
Inkey( 0 )
CLS
? 'NEWRDD->( dbCloseArea() )'
@@ -350,25 +351,25 @@ function Main()
? 'next'
? "Press any key to continue..."
InKey( 0 )
Inkey( 0 )
CLS
NEWRDD->( dbCloseArea() )
Select( "TESTDBF" )
SELECT( "TESTDBF" )
SORT ON FIRST /DC, AGE /D TO NEWRDD
dbUseArea( .T., "DBF", "newrdd", "NEWRDD", .F., .F. )
dbUseArea( .T. , "DBF", "newrdd", "NEWRDD", .F. , .F. )
? "RecCount:", NEWRDD->( RecCount() )
for nI := 1 to 8
FOR nI := 1 TO 8
? NEWRDD->FIRST, NEWRDD->AGE
NEWRDD->( dbSkip() )
next
NEXT
? "..."
NEWRDD->( dbGoBottom() )
NEWRDD->( dbSkip( -8 ) )
for nI := 1 to 8
NEWRDD->( dbSkip( - 8 ) )
FOR nI := 1 TO 8
? NEWRDD->FIRST, NEWRDD->AGE
NEWRDD->( dbSkip() )
next
NEXT
return nil
RETURN

22
harbour/tests/nums.prg
View File

@@ -1,17 +1,17 @@
//
// $Id$
//
/*
* $Id$
*/
// Testing the different numeric formats Harbour produces
function main()
PROCEDURE Main()
local a := 0 // it should generate a _ZERO pcode opcode
local b := 123 // it should generate a _PUSHINT pcode opcodes
local c := 50000 // it should generate a _PUSHLONG pcode opcodes
local d := 12000.123 // it should generate a _PUSHDOUBLE pcode opcodes
local e := 0xABAB // Automatic support for hexadecimal numbers
local f := .12
LOCAL a := 0 // it should generate a _ZERO pcode opcode
LOCAL b := 123 // it should generate a _PUSHINT pcode opcodes
LOCAL c := 50000 // it should generate a _PUSHLONG pcode opcodes
LOCAL d := 12000.123 // it should generate a _PUSHDOUBLE pcode opcodes
LOCAL e := 0xABAB // Automatic support for hexadecimal numbers
LOCAL f := .12
QOut( a )
QOut( b )
@@ -19,4 +19,4 @@ function main()
QOut( d )
QOut( e )
return nil
RETURN

47
harbour/tests/objarr.prg
View File

@@ -1,6 +1,6 @@
//
// $Id$
//
/*
* $Id$
*/
//
// Object Array syntax test
@@ -11,9 +11,9 @@
// Placed in the public domain
//
Function Main
PROCEDURE Main()
local o := TNumber():New()
LOCAL o := TNumber():New()
QOut( "Direct reference : ", ToChar( o:x ) )
@@ -25,9 +25,9 @@ Function Main
o:Get()[2] := 4
QOut( "Assign 4 : ", ToChar( o:x ) )
QOut( "Post increment : ", o:x[1]++ , o:Get()[2]++ )
QOut( "Post increment : ", o:x[1] ++ , o:Get()[2] ++ )
QOut( "After : ", o:x[1] , o:Get()[2] )
QOut( "Pre decrement : ", --o:x[1] , --o:Get()[2] )
QOut( "Pre decrement : ", -- o:x[1] , -- o:Get()[2] )
QOut( "After : ", o:x[1] , o:Get()[2] )
o:x[1] += 2
@@ -55,36 +55,37 @@ Function Main
QOut( "To the power 3 : ", ToChar( o:x ) )
QOut( "Global stack" )
Debug( __dbgvmStkGList() )
QOut( "Statics")
Debug( __dbgvmVarSList() )
return NIL
Debug( __dbgVMStkGList() )
QOut( "Statics" )
Debug( __dbgVMVarSList() )
Function TNumber() // Very simple class
RETURN
static oNumber
FUNCTION TNumber() // Very simple class
if oNumber == NIL
STATIC oNumber
IF oNumber == NIL
oNumber := HBClass():New( "TNumber" )
oNumber:AddData ( "x" )
oNumber:AddMethod( "Get", @Get() )
oNumber:AddMethod( "New", @New() )
oNumber:Create()
endif
return oNumber:Instance()
ENDIF
RETURN oNumber:Instance()
static function New()
STATIC FUNCTION New()
local self := QSelf()
LOCAL self := QSelf()
::x := {1,1}
return self
::x := { 1, 1 }
RETURN self
static function Get()
STATIC FUNCTION Get()
local self := QSelf()
LOCAL self := QSelf()
return ::x
return ::x

42
harbour/tests/objasign.prg
View File

@@ -1,6 +1,6 @@
//
// $Id$
//
/*
* $Id$
*/
//
// Object Array syntax test
@@ -11,9 +11,9 @@
// Placed in the public domain
//
Function Main
PROCEDURE Main()
local o := TNumber():New()
LOCAL o := TNumber():New()
QOut( "Direct reference : ", o:x )
@@ -23,9 +23,9 @@ Function Main
o:x := 4
QOut( "Assign 4 : ", o:x )
QOut( "Post increment : ", o:x++ )
QOut( "Post increment : ", o:x ++ )
QOut( "After : ", o:x )
QOut( "Pre decrement : ", --o:x )
QOut( "Pre decrement : ", -- o:x )
QOut( "After : ", o:x )
o:x += 2
@@ -47,30 +47,30 @@ Function Main
QOut( "To the power 3 : ", o:x )
QOut( "Global stack" )
Debug( __dbgvmStkGList() )
QOut( "Statics")
Debug( __dbgvmVarSList() )
return NIL
Debug( __dbgVMStkGList() )
QOut( "Statics" )
Debug( __dbgVMVarSList() )
Function TNumber() // Very simple class
RETURN
static oNumber
FUNCTION TNumber() // Very simple class
if oNumber == NIL
STATIC oNumber
IF oNumber == NIL
oNumber := HBClass():New( "TNumber" )
oNumber:AddData ( "x" )
oNumber:AddData( "x" )
oNumber:AddMethod( "New", @New() )
oNumber:Create()
endif
return oNumber:Instance()
ENDIF
RETURN oNumber:Instance()
static function New()
STATIC FUNCTION New()
local self := QSelf()
LOCAL self := QSelf()
::x := 1
return self
RETURN self

41
harbour/tests/objects.prg
View File

@@ -1,15 +1,15 @@
//
// $Id$
//
/*
* $Id$
*/
// Testing Harbour classes and objects management
// be aware Harbour provides a much simpler way using Class HBClass (source\rtl\class.prg)
// be aware Harbour provides a much simpler way using Class HBClass
#include "hboo.ch"
function Main()
PROCEDURE Main()
local oObject := TAny():New()
LOCAL oObject := TAny():New()
QOut( ValType( oObject ) )
QOut( Len( oObject ) ) // 3 datas !
@@ -18,49 +18,48 @@ function Main()
QOut( oObject:ClassName() ) // retrieves its class name
oObject:Test() // This invokes the below defined Test function
// See QSelf() and :: use
// See QSelf() and :: use
QOut( oObject:cName )
oObject:DoNothing() // a virtual method does nothing,
// but it is very usefull for Classes building logic
// but it is very usefull for Classes building logic
return nil
RETURN
function TAny() /* builds a class */
FUNCTION TAny() /* builds a class */
static hClass
STATIC hClass
if hClass == nil
IF hClass == nil
hClass := __clsNew( "TANY", 3 ) // cClassName, nDatas
__clsAddMsg( hClass, "cName", 1, HB_OO_MSG_DATA ) // retrieve data
__clsAddMsg( hClass, "_cName", 1, HB_OO_MSG_DATA ) // assign data. Note the '_'
__clsAddMsg( hClass, "New", @New(), HB_OO_MSG_METHOD )
__clsAddMsg( hClass, "Test", @Test(), HB_OO_MSG_METHOD )
__clsAddMsg( hClass, "DoNothing", 0, HB_OO_MSG_VIRTUAL )
endif
ENDIF
/* warning: we are not defining datas names and methods yet */
return __clsInst( hClass ) // creates an object of this class
RETURN __clsInst( hClass ) // creates an object of this class
static function New()
STATIC FUNCTION New()
local Self := QSelf()
LOCAL Self := QSelf()
QOut( ValType( Self ) )
QOut( "Inside New()" )
::cName := "Harbour OOP"
return Self
RETURN Self
static function Test()
STATIC FUNCTION Test()
local Self := QSelf() // We access Self for this method
LOCAL Self := QSelf() // We access Self for this method
QOut( "Test method invoked!" )
QOut( ::ClassName() ) // :: means Self: It is a Harbour built-in operator
return nil
RETURN nil

37
harbour/tests/omacro.prg
View File

@@ -7,18 +7,19 @@
* using macro syntax
*/
PROCEDURE MAIN()
LOCAL obj:=ErrorNew()
PROCEDURE Main()
LOCAL obj := ErrorNew()
MEMVAR send1, send2
PRIVATE send1:="_description"
PRIVATE send2:="_tries"
PRIVATE send1 := "_description"
PRIVATE send2 := "_tries"
obj:tries := 1
obj:&send1 := 'test'
obj:&send1 := "test"
obj:tries += 1
obj:tries++
obj:tries ++
++obj:tries
WITH OBJECT obj
@@ -27,25 +28,25 @@ PROCEDURE MAIN()
++:tries
/*
Notice that for post/pre increment decrement operators and
for assigments (:=,+=,-=,*=,/=) the macro have to
start from the underscore symbol '_'
Notice that for post/pre increment decrement operators and
for assigments (:=,+=,-=,*=,/=) the macro have to
start from the underscore symbol '_'
To access the object variable using macro the '_' should be omitted
To access the object variable using macro the '_' should be omitted
*/
:&send2 +=1
:&send2++
:&send2 += 1
:&send2 ++
++:&send2
++:&(send2)
++:&( send2 )
:&( send2 ) := :&( SUBSTR(send2,2) ) +1
:&( send2 ) := :&( SubStr( send2,2 ) ) + 1
:&send1 +=' description'
:&(send1) += ' of '
:&send1 += " description"
:&( send1 ) += " of "
ENDWITH
obj:&( "_"+ SUBSTR(send1,2) ) += "Error object"
? send1, "=", obj:&( SUBSTR(send1,2) )
obj:&( "_" + SubStr( send1,2 ) ) += "Error object"
? send1, "=", obj:&( SubStr( send1, 2 ) )
? send2, "=", obj:tries
RETURN

130
harbour/tests/onidle.prg
View File

@@ -1,75 +1,77 @@
//
// $Id$
//
/*
* $Id$
*/
#include "hbmemory.ch"
FUNCTION MAIN
LOCAL nH1, nH2, nH3, nH4
LOCAL n:=0
LOCAL aSign:={"|", "/", "-", "\" }
LOCAL nPrev:=SECONDS()
PROCEDURE Main()
CLS
? " Time: Memory used: Miliseconds elapsed"
?
? "Can you see it ??? :) Press any key or wait 30 seconds"
?
?
@ 10,2 SAY "Memory before TEST() call" + STR( MEMORY(HB_MEM_USED) )
TEST()
@ 11,2 SAY "Memory after TEST() and before collecting" + STR( MEMORY(HB_MEM_USED) )
HB_GCALL()
@ 12,2 SAY "Memory after collecting" + STR( MEMORY(HB_MEM_USED) )
nH1 := HB_IDLEADD( {|| DEVPOS(0,01), DEVOUT( TIME() ) } )
nH2 := HB_IDLEADD( {|| DEVPOS(0,21), TEST(), DEVOUT( MEMORY(HB_MEM_USED) ) } )
nH3 := HB_IDLEADD( {|| DEVPOS(0,41), IIF(n==4,n:=1,n++),DEVOUT(aSign[n]) } )
nH4 := HB_IDLEADD( {|| DEVPOS(0,61), DEVOUT( 1000*(SECONDS()-nPrev) ), nPrev:=SECONDS() } )
LOCAL nH1, nH2, nH3, nH4
LOCAL n := 0
LOCAL aSign := { "|", "/", "-", "\" }
LOCAL nPrev := Seconds()
? VALTYPE(nH1), nH1, VALTYPE(nH2), nH2, VALTYPE(nH3), nH3, VALTYPE(nH4), nH4
INKEY( 30 )
IF !EMPTY(nH3)
@ 14,2 SAY "Delete task 3: " + HB_VALTOSTR(nH3)
HB_IDLEDEL( nH3 )
ENDIF
IF !EMPTY(nH2)
@ 15,2 SAY "Delete task 2: " + HB_VALTOSTR(nH2)
HB_IDLEDEL( nH2 )
ENDIF
IF !EMPTY(nH1)
@ 16,2 SAY "Delete task 1: " + HB_VALTOSTR(nH1)
HB_IDLEDEL( nH1 )
ENDIF
IF !EMPTY(nH4)
@ 17,2 SAY "Delete task 4: " + HB_VALTOSTR(nH4)
HB_IDLEDEL( nH4 )
ENDIF
CLS
? " Time: Memory used: Miliseconds elapsed"
?
? "Can you see it ??? :) Press any key or wait 30 seconds"
?
?
@ 10, 2 SAY "Memory before TEST() call" + Str( Memory( HB_MEM_USED ) )
TEST()
@ 11, 2 SAY "Memory after TEST() and before collecting" + Str( Memory( HB_MEM_USED ) )
hb_gcAll()
@ 12, 2 SAY "Memory after collecting" + Str( Memory( HB_MEM_USED ) )
nH1 := hb_idleAdd( { || DevPos( 0,01 ), DevOut( Time() ) } )
nH2 := hb_idleAdd( { || DevPos( 0,21 ), TEST(), DevOut( Memory(HB_MEM_USED ) ) } )
nH3 := hb_idleAdd( { || DevPos( 0,41 ), IIF( n == 4,n := 1,n ++ ), DevOut( aSign[n] ) } )
nH4 := hb_idleAdd( { || DevPos( 0,61 ), DevOut( 1000 * (Seconds() - nPrev ) ), nPrev := Seconds() } )
@ 18,2 SAY "Memory after idle states" + STR( MEMORY(HB_MEM_USED) )
HB_GCALL()
@ 19,2 SAY "Memory after collecting" + STR( MEMORY(HB_MEM_USED) )
? ValType( nH1 ), nH1, ValType( nH2 ), nH2, ValType( nH3 ), nH3, ValType( nH4 ), nH4
RETURN 1
Inkey( 30 )
IF !Empty( nH3 )
@ 14, 2 SAY "Delete task 3: " + hb_ValToStr( nH3 )
hb_idleDel( nH3 )
ENDIF
IF !Empty( nH2 )
@ 15, 2 SAY "Delete task 2: " + hb_ValToStr( nH2 )
hb_idleDel( nH2 )
ENDIF
IF !Empty( nH1 )
@ 16, 2 SAY "Delete task 1: " + hb_ValToStr( nH1 )
hb_idleDel( nH1 )
ENDIF
IF !Empty( nH4 )
@ 17, 2 SAY "Delete task 4: " + hb_ValToStr( nH4 )
hb_idleDel( nH4 )
ENDIF
PROC TEST()
LOCAL a, b, c
LOCAL cb
@ 18, 2 SAY "Memory after idle states" + Str( Memory( HB_MEM_USED ) )
hb_gcAll()
@ 19, 2 SAY "Memory after collecting" + Str( Memory( HB_MEM_USED ) )
a := ARRAY( 3 )
b := ARRAY( 3 )
c := ARRAY( 3 )
a[1] :=a
a[2] :=b
a[3] :=c
b[1] :=a
b[2] :=b
b[3] :=c
c[1] :=a
c[2] :=b
c[3] :=c
RETURN
cb := {|x| x:=cb}
EVAL( cb )
PROCEDURE TEST()
RETURN
LOCAL a, b, c
LOCAL cb
a := Array( 3 )
b := Array( 3 )
c := Array( 3 )
a[ 1 ] := a
a[ 2 ] := b
a[ 3 ] := c
b[ 1 ] := a
b[ 2 ] := b
b[ 3 ] := c
c[ 1 ] := a
c[ 2 ] := b
c[ 3 ] := c
cb := {| x | x := cb }
Eval( cb )
RETURN

12
harbour/tests/os.prg
View File

@@ -1,11 +1,11 @@
//
// $Id$
//
/*
* $Id$
*/
// Testing the OS function
function Main()
PROCEDURE Main()
QOUT( OS() )
QOut( OS() )
return nil
RETURN

32
harbour/tests/output.prg
View File

@@ -1,6 +1,6 @@
//
// $Id$
//
/*
* $Id$
*/
// Testing Harbour device management.
/* Harbour Project source code
@@ -10,26 +10,26 @@
#include "set.ch"
function Main()
PROCEDURE Main()
OUTSTD (hb_eol(), "Testing Harbour device management on", DATE())
OutStd( hb_eol(), "Testing Harbour device management on", Date() )
SET ALTERNATE TO OUTPUT_A ADDITIVE
SET (_SET_EXTRAFILE, "output_e.ext", .F.)
SET( _SET_EXTRAFILE, "output_e.ext", .F. )
SET PRINTER TO OUTPUT_P
SET MARGIN TO 5
QOUT ("SCREEN, EXTRA, NOT ALTERNATE, NOT PRINTER")
@ 5,5 SAY "SCREEN, NOT EXTRA, NOT ALTERNATE NOT PRINTER"
QOut( "SCREEN, EXTRA, NOT ALTERNATE, NOT PRINTER" )
@ 5, 5 SAY "SCREEN, NOT EXTRA, NOT ALTERNATE NOT PRINTER"
SET ALTERNATE ON
SET PRINTER ON
QOUT ("SCREEN, EXTRA, ALTERNATE AND PRINTER")
@ 10,10 SAY "SCREEN, NOT EXTRA, NOT ALTERNATE, NOT PRINTER"
QOut( "SCREEN, EXTRA, ALTERNATE AND PRINTER" )
@ 10, 10 SAY "SCREEN, NOT EXTRA, NOT ALTERNATE, NOT PRINTER"
SET DEVICE TO PRINTER
SET (_SET_EXTRAFILE, "")
QOUT ("SCREEN, ALTERNATE AND PRINTER AGAIN, BUT NOT EXTRA")
SET( _SET_EXTRAFILE, "" )
QOut( "SCREEN, ALTERNATE AND PRINTER AGAIN, BUT NOT EXTRA" )
SET PRINTER OFF
SET (_SET_EXTRAFILE, "output_e.ext", .T.)
QOUT ("SCREEN, EXTRA, AND ALTERNATE, BUT NOT PRINTER")
@ 15,15 SAY "PRINTER, NOT SCREEN, NOT ALTERNATE"
SET( _SET_EXTRAFILE, "output_e.ext", .T. )
QOut( "SCREEN, EXTRA, AND ALTERNATE, BUT NOT PRINTER" )
@ 15, 15 SAY "PRINTER, NOT SCREEN, NOT ALTERNATE"
EJECT
return nil
RETURN

51
harbour/tests/overload.prg
View File

@@ -1,6 +1,6 @@
//
// $Id$
//
/*
* $Id$
*/
//
// DynObj
@@ -17,12 +17,11 @@
// Placed in the public domain
//
#include "hbclass.ch"
function Main()
PROCEDURE Main()
local oString := TString():New( "Hello" )
LOCAL oString := TString():New( "Hello" )
QOut( "Testing TString with Operator Overloading" )
QOut( oString:cValue )
@@ -43,34 +42,32 @@ function Main()
QOut( "Concatenation + :", oString + "Hello" )
QOut( "Concatenation - :", oString - "Hello" )
QOut( "Array index[2] :", oString[2] )
QOut( "Array index[3] := 'X' :", oString[3]:='X' )
QOut( "Array index[3] := 'X' :", oString[3] := 'X' )
QOut( oString:cValue )
return nil
RETURN nil
CREATE CLASS tString
create class tString
VAR cValue
VAR cValue
METHOD New( cText ) INLINE ::cValue := cText, self
METHOD New(cText) INLINE ::cValue := cText, self
OPERATOR "=" ARG cArg INLINE ::cValue = cArg
OPERATOR "==" ARG cArg INLINE ::cValue == cArg
OPERATOR "!=" ARG cArg INLINE ::cValue != cArg
OPERATOR "<" ARG cArg INLINE ::cValue < cArg
OPERATOR "<=" ARG cArg INLINE ::cValue <= cArg
OPERATOR ">" ARG cArg INLINE ::cValue > cArg
OPERATOR ">=" ARG cArg INLINE ::cValue >= cArg
OPERATOR "+" ARG cArg INLINE ::cValue + cArg
OPERATOR "-" ARG cArg INLINE ::cValue - cArg
OPERATOR "$" ARG cArg INLINE ::cValue $ cArg
OPERATOR "[]" ARG nIndex INLINE iif( pcount()>2, ;
::cValue := stuff( ::cValue, nIndex, 1, hb_pvalue(3) ), ;
substr( ::cValue, nIndex, 1 ) )
endclass
OPERATOR "=" ARG cArg INLINE ::cValue = cArg
OPERATOR "==" ARG cArg INLINE ::cValue == cArg
OPERATOR "!=" ARG cArg INLINE ::cValue != cArg
OPERATOR "<" ARG cArg INLINE ::cValue < cArg
OPERATOR "<=" ARG cArg INLINE ::cValue <= cArg
OPERATOR ">" ARG cArg INLINE ::cValue > cArg
OPERATOR ">=" ARG cArg INLINE ::cValue >= cArg
OPERATOR "+" ARG cArg INLINE ::cValue + cArg
OPERATOR "-" ARG cArg INLINE ::cValue - cArg
OPERATOR "$" ARG cArg INLINE ::cValue $ cArg
OPERATOR "[]" ARG nIndex INLINE iif( PCount() > 2, ;
::cValue := Stuff( ::cValue, nIndex, 1, hb_PValue( 3 ) ), ;
SubStr( ::cValue, nIndex, 1 ) )
ENDCLASS
/*

40
harbour/tests/parexpr.prg
View File

@@ -1,6 +1,6 @@
//
// $Id$
//
/*
* $Id$
*/
// The following code tests harbour's ability to cope with parenthesized
// expressions.
@@ -13,9 +13,9 @@
#pragma -es0
#endif
Function Main()
Local x
Local y
PROCEDURE Main()
Local x
Local y
// Simple one to start with.
x := ( 1 )
@@ -24,26 +24,26 @@ Local y
// Now with a little more complex:
x := ( 1, 2 )
? x
// And a little more, this is really the same as the previous one.
x := ( 1, 2, 3 )
? x
// Expression within expression
x := ( ( 1, 2, 3 ) )
? x
// And a little more:
x := ( ( 1, 2, 3 ), ( 1, 2, 3 ) )
? x
// Some inline assignments
x := ( y := 10, y )
? x
x := ( ( y := ( 1, 2, 3) ), y * ( 10, 20, 30 ) )
? x
// Now mix with statements and functions
? ( 1, 2, 3 )
@@ -52,19 +52,19 @@ Local y
Else
? "Borken"
EndIf
If ( x := 10, y := ( x == 10 ) )
? "Working"
Else
? "Broken"
EndIf
If ( Something( 1, 2, 3 ), .T. )
? "Working"
Else
? "Broken"
EndIf
?
// Now even some more testing of related code
@@ -75,7 +75,7 @@ Local y
? IF( (.T. .OR. .F.), IF( .T., "Working", "Broken" ), IF( .F., "Broken", "Working" ) )
/* The following code should generate syntax error if uncommented
/* The following code should generate syntax error if uncommented
* because IF token followed by any three expressions is interpreted
* as IIF inline
*/
@@ -85,10 +85,10 @@ Local y
// ? "Broken"
// ENDIF
Return( NIL )
Return
Static Function Something( x, y, z )
// This does something and it does it well/
Return( NIL )
// This does something and it does it well/
Return( NIL )

37
harbour/tests/passref.prg
View File

@@ -1,27 +1,28 @@
//
// $Id$
//
/*
* $Id$
*/
/* test of pass by reference @ */
function main
local a := 10
local b := "X"
PROCEDURE Main()
qout('a := 10',a)
qout('b := "X"',b)
LOCAL a := 10
LOCAL b := "X"
testfun(@a, @b)
qout('return of "a" should = 20',a,iif(a == 20,"worked","failed"))
qout('return of "b" should = A',b,iif(b == "A","worked","failed"))
QOut( 'a := 10', a )
QOut( 'b := "X"', b )
return nil
testfun( @a, @b )
QOut( 'return of "a" should = 20', a, iif( a == 20,"worked","failed" ) )
QOut( 'return of "b" should = A', b, iif( b == "A","worked","failed" ) )
function testfun(b,c)
b := b + 10
c := "A"
qout('a pointer+10 =',b)
qout('b pointer := "A" =',c)
RETURN
return nil
FUNCTION testfun( b, c )
b := b + 10
c := "A"
QOut( 'a pointer+10 =', b )
QOut( 'b pointer := "A" =', c )
RETURN nil

17
harbour/tests/procline.prg
View File

@@ -1,14 +1,13 @@
//
// $Id$
//
/*
* $Id$
*/
PROCEDURE Main()
FUNCTION Main()
? "hello 1", ProcLine(), "Expected: ", 8
? "hello 1", ProcLine(), "Expected: ", 8
? "hello 2", ProcLine(), "Expected: ", 10
? "hello 2", ProcLine(), "Expected: ", 10
? "hello 3", ProcLine(), "Expected: ", 12
? "hello 3", ProcLine(), "Expected: ", 12
RETURN NIL
RETURN

35
harbour/tests/procname.prg
View File

@@ -1,42 +1,41 @@
//
// $Id$
//
/*
* $Id$
*/
// Testing Harbour ProcName() and ProcLine()
#define CRLF Chr( 13 ) + Chr( 10 )
function Main()
PROCEDURE Main()
Two()
return nil
RETURN
function Two()
FUNCTION Two()
Three()
return nil
RETURN nil
function Three()
FUNCTION Three()
Four()
return nil
RETURN nil
function Four()
FUNCTION Four()
Five()
return nil
RETURN nil
function Five()
FUNCTION Five()
local n := 0
LOCAL n := 0
while ! Empty( ProcName( n ) )
QQOut( "Called from: ", ProcName( n ), ProcLine( n++ ), CRLF )
end
return nil
WHILE ! Empty( ProcName( n ) )
QQOut( "Called from: ", ProcName( n ), ProcLine( n ++ ), CRLF )
ENDDO
RETURN nil

20
harbour/tests/recursiv.prg
View File

@@ -1,19 +1,19 @@
//
// $Id$
//
/*
* $Id$
*/
// testing recursive calls
function main()
PROCEDURE Main()
QOut( "Testing recursive calls" + Chr( 13 ) + Chr( 10 ) )
QOut( "Testing recursive calls" + Chr( 13 ) + Chr( 10 ) )
QOut(f(10))
QOut( f( 10 ) )
QOut( 10 * 9 * 8 * 7 * 6 * 5 * 4 * 3 * 2 * 1 )
QOut( 10 * 9 * 8 * 7 * 6 * 5 * 4 * 3 * 2 * 1 )
return nil
RETURN
function f(a)
return iif(a<2,1,a*f(a-1))
FUNCTION f( a )
RETURN iif( a < 2, 1, a * f( a - 1 ) )

32
harbour/tests/returns.prg
View File

@@ -1,10 +1,10 @@
//
// $Id$
//
/*
* $Id$
*/
// Testing multiple returns into a function
function Main()
PROCEDURE Main()
QOut( "From Main()" )
@@ -16,20 +16,20 @@ function Main()
QOut( "back to Main()" )
return nil
RETURN
function Two( n )
FUNCTION Two( n )
do case
case n == 1
QOut( "n == 1" )
return nil
DO CASE
CASE n == 1
QOut( "n == 1" )
RETURN nil
case n == 2
QOut( "n == 2" )
return nil
endcase
CASE n == 2
QOut( "n == 2" )
RETURN nil
ENDCASE
QOut( "This message should not been seen" )
QOut( "This message should not been seen" )
return nil
RETURN nil

29
harbour/tests/round.prg
View File

@@ -1,6 +1,6 @@
//
// $Id$
//
/*
* $Id$
*/
// Testing Harbour rounding.
/* Harbour Project source code
@@ -8,17 +8,18 @@
Donated to the public domain on 2001-03-08 by David G. Holm <dholm@jsd-llc.com>
*/
function main()
local n, value := -5
PROCEDURE Main()
for n := 1 to 100
OUTSTD(hb_eol())
OUTSTD(value)
OUTSTD(round(value, 3))
OUTSTD(round(value, 2))
OUTSTD(round(value, 1))
OUTSTD(round(value, 0))
LOCAL n, value := - 5
FOR n := 1 TO 100
OutStd( hb_eol() )
OutStd( value )
OutStd( Round( value, 3 ) )
OutStd( Round( value, 2 ) )
OutStd( Round( value, 1 ) )
OutStd( Round( value, 0 ) )
value += 0.001
next
NEXT
return nil
RETURN

142
harbour/tests/rtfclass.prg
View File

@@ -1,142 +0,0 @@
//
// $Id$
//
/*
* harbour rtfclass demo
* notes : - raw enough but it works
- using hb_f*() - some compilers are not friendly with this :(
- rtf is assumed to have association
* initial release : 23 June 1999 Andi Jahja
* this program compiles fine on Borland C/C++ 5.0
* tested under Windows 98 only with RTF associated to Winword
* works with printable ascii only
* placed in the public domain
*/
#define CRLF CHR(13) + CHR(10)
function main()
local ortf := trtf():new("test.rtf")
local htest := fcreate( "rtf_test.txt")
local ctest := ""
// create a plain text file
ctest += "This is +bHarbour © RTF Class-b" + CRLF
ctest += "THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG" + CRLF
ctest += "+bTHE QUICK BROWN FOX JUMPS OVER THE LAZY DOG-b" + CRLF
ctest += "+iTHE QUICK BROWN FOX JUMPS OVER THE LAZY DOG-i" + CRLF
ctest += "+buTHE QUICK BROWN FOX JUMPS OVER THE LAZY DOG-bu" + CRLF
ctest += "+buiTHE QUICK BROWN FOX JUMPS OVER THE LAZY DOG-bui" + CRLF
ctest += "THE +bQUICK-b +buBROWN-bu +buiFOX-bui +iJUMPS-i +uOVER-u +ilTHE-il +uLAZY-u +buDOG-bu" + CRLF
fwrite( htest, ctest )
fclose( htest )
// convert text file to rtf
ortf:write("rtf_test.txt")
ortf:close()
// execute file association ( windows only )
if lower( os() ) == "windows"
// assuming start.exe is exist
__run( "start test.rtf" )
endif
return nil
function trtf()
static oclass
if oclass == nil
oclass := HBClass():new( "trtf" )
oclass:adddata( "nhandle" )
oclass:addmethod( "new", @new() )
oclass:addmethod( "write", @write() )
oclass:addmethod( "close", @close() )
oclass:create()
endif
return oclass:instance()
static function new( cfilename )
local self := qself()
::nhandle := fcreate( cfilename )
fwrite( ::nhandle,;
"{\rtf1\ansi\deff0{\fonttbl {\f0\fnil\fcharset0 Courier New;}{\f1\fnil\fcharset0 Arial;}}"+;
"\uc1\pard\lang1033\ulnone\f0\fs20"+CRLF)
return self
static function write( csource )
local self := qself()
local cchar, cline, xatt, i, _xatt
local n, nchar, xchar, y
// These are character attributes, self-defined
// + means a turn-on
// - means a turn-off
local attrib := {;
{ "+b" , "\b " } /* turn bold on*/ ,;
{ "+bu" , "\ul\b " } /* turn bold_underline on */ ,;
{ "+bi" , "\b\i " } /* turn bold_italic on */ ,;
{ "+bui", "\ul\b\i " } /* turn bold_underline_italic on */ ,;
{ "+i" , "\i " } /* turn italic on */ ,;
{ "+il" , "\ul\i " } /* turn italic_underline on */ ,;
{ "+u" , "\ul " } /* turn underline on */ ,;
{ "-b" , "\b0 " } /* turn bold off */ ,;
{ "-bu" , "\b0\ulnone " } /* turn bold_underline off */ ,;
{ "-bi" , "\b0\i0 " } /* turn bold_italic off */ ,;
{ "-bui", "\b0\i0\ulnone " } /* turn bold_underline_italic off */,;
{ "-i" , "\i0 " } /* turn italic off */ ,;
{ "-il" , "\ulnone\i0 " } /* turn italic_underline off */ ,;
{ "-u" , "\ulnone " } /* turn underline off */ }
hb_fuse( csource ) // open source file
while !hb_feof() // read the file line by line
cline := hb_freadln() + "\par"
y := len( cline )
for nchar := 1 to y
cchar := substr( cline, nchar, 1 )
// todo : i need function dec2hex()
// to convert ascii to 2-characters hex
// ie : dec2hex( "H" ) -> 48
if cchar == "+" .or. cchar == "-"
xatt := cchar + ;
substr( cline, nchar + 1, 1 ) + ;
substr( cline, nchar + 2, 1 ) + ;
substr( cline, nchar + 3, 1 )
if ( i := ascan( attrib, { |e| e[1] == xatt } ) ) > 0
fwrite( ::nhandle, attrib[i][2] )
nchar := nchar + len( xatt ) - 1
else
// 3 attributes
xatt := left( xatt, 3 )
if ( i := ascan( attrib, { |e| e[1] == xatt } ) ) > 0
fwrite( ::nhandle, attrib[i][2] )
nchar := nchar + len( xatt ) - 1
else
// 2 attributes
xatt := left( xatt, 2 )
if ( i := ascan( attrib, { |e| e[1] == xatt } ) ) > 0
fwrite( ::nhandle, attrib[i][2] )
nchar := nchar + len( xatt ) - 1
else
fwrite( ::nhandle, cchar )
endif
endif
endif
else
fwrite( ::nhandle, cchar )
endif
next
fwrite( ::nhandle, CRLF )
hb_fskip() // read next line
enddo
hb_fuse()
return ( self )
static function close()
local self := qself()
fwrite( ::nhandle, "\f1\fs16\par"+CRLF+"}" )
fclose( ::nhandle )
return self

34
harbour/tests/say.prg
View File

@@ -1,22 +1,24 @@
//
// $Id$
//
/*
* $Id$
*/
// Tests @ SAY with and without PICTURE clauses
function Main()
PROCEDURE Main()
CLS
SET CENTURY ON
@ 2,39 TO 7,39 DOUBLE
@ 0,0 SAY "Testing @ SAY with and without PICTURE clauses"
@ 0,60 SAY DATE()
@ 2, 39 TO 7, 39 DOUBLE
@ 0, 0 SAY "Testing @ SAY with and without PICTURE clauses"
@ 0, 60 SAY Date()
SET CENTURY OFF
@ 2,1 SAY -1.25
@ 2,41 SAY -1.25 PICTURE "@( 99,999.99"
@ 3,1 SAY 1.25 PICTURE "@( 9,999.99"
@ 3,41 SAY 1.25 PICTURE "@( $9,999.99"
@ 5,1 SAY DATE()
@ 5,41 SAY DATE() PICTURE "@E"
@ 7,1 SAY "Hello"
@ 7,41 SAY "Hello" PICTURE "@!"
return nil
@ 2, 1 SAY - 1.25
@ 2, 41 SAY - 1.25 PICTURE "@( 99,999.99"
@ 3, 1 SAY 1.25 PICTURE "@( 9,999.99"
@ 3, 41 SAY 1.25 PICTURE "@( $9,999.99"
@ 5, 1 SAY Date()
@ 5, 41 SAY Date() PICTURE "@E"
@ 7, 1 SAY "Hello"
@ 7, 41 SAY "Hello" PICTURE "@!"
RETURN

2
harbour/tests/sbartest.prg
View File

@@ -19,7 +19,7 @@
#define B_THIN ( Chr( 219 ) + Chr( 223 ) + Chr( 219 ) + Chr( 219 ) + ;
Chr( 219 ) + Chr( 220 ) + Chr( 219 ) + Chr( 219 ) )
PROCEDURE main()
PROCEDURE Main()
InitScrlBar()

75
harbour/tests/scroll.prg
View File

@@ -1,6 +1,6 @@
//
// $Id$
//
/*
* $Id$
*/
// Testing Harbour screen scrolling (requires the GT API)
/* Harbour Project source code
@@ -9,10 +9,11 @@
*/
#include "box.ch"
function main()
local ct
FUNCTION main()
DEVPOS(MAXROW(),0)
LOCAL ct
DevPos( MaxRow(), 0 )
DispBegin()
? "If you have the GT API linked in, the screen will be blanked, a text block"
? "will be drawn in the upper-left hand corner of the screen, and then the inside"
@@ -24,45 +25,47 @@ local ct
DispEnd()
Pause()
SET COLOR TO "GR+/RB"
SET COLOR TO "GR+/RB"
CLS
@ 0,0,14,45 BOX B_SINGLE
@ 0,0 SAY "01234567890123456789012345678901"
@ 1,0 SAY "01234567890123456789012345678901"
@ 2,0 SAY "01234567890123456789012345678901"
@ 3,0 SAY "01234 78901"
@ 4,0 SAY "01234 This is a test. 78901"
@ 5,0 SAY "01234 This is only a test. 78901"
@ 6,0 SAY "01234 Had this been a real 78901"
@ 7,0 SAY "01234 emergency, you would 78901"
@ 8,0 SAY "01234 be dead now. 78901"
@ 9,0 SAY "01234 78901"
@ 10,0 SAY "01234567890123456789012345678901"
@ 11,0 SAY "01234567890123456789012345678901"
@ 12,0 SAY "01234567890123456789012345678901"
@ 13,0 SAY "0 1 2 3 "
@ 0, 0, 14, 45 BOX B_SINGLE
@ 0, 0 SAY "01234567890123456789012345678901"
@ 1, 0 SAY "01234567890123456789012345678901"
@ 2, 0 SAY "01234567890123456789012345678901"
@ 3, 0 SAY "01234 78901"
@ 4, 0 SAY "01234 This is a test. 78901"
@ 5, 0 SAY "01234 This is only a test. 78901"
@ 6, 0 SAY "01234 Had this been a real 78901"
@ 7, 0 SAY "01234 emergency, you would 78901"
@ 8, 0 SAY "01234 be dead now. 78901"
@ 9, 0 SAY "01234 78901"
@ 10, 0 SAY "01234567890123456789012345678901"
@ 11, 0 SAY "01234567890123456789012345678901"
@ 12, 0 SAY "01234567890123456789012345678901"
@ 13, 0 SAY "0 1 2 3 "
Pause()
//save/restore test
cT := SAVESCREEN( 0,0, 13, 31 )
RESTSCREEN( 10,40, 23, 71, cT )
//save/restore test
cT := SaveScreen( 0, 0, 13, 31 )
RestScreen( 10, 40, 23, 71, cT )
pause()
Scroll (1, 1, 11, 30, -2, -5)
Scroll ( 1, 1, 11, 30, - 2, - 5 )
pause()
Scroll (1, 1, 11, 30, 2, 5)
Scroll ( 1, 1, 11, 30, 2, 5 )
pause()
Scroll (1, 1, 11, 30, -5, 2)
Scroll ( 1, 1, 11, 30, - 5, 2 )
pause()
Scroll (1, 1, 11, 30, 7, -12)
Scroll ( 1, 1, 11, 30, 7, - 12 )
pause()
SET COLOR TO "W+/R"
Scroll (1, 1, 11, 30, 0, 0 )
Scroll ( 1, 1, 11, 30, 0, 0 )
pause()
return nil
RETURN NIL
function pause()
DevPos (MAXROW() - 2, 0)
__ACCEPT ("pause: ")
return nil
FUNCTION pause()
DevPos ( MaxRow() - 2, 0 )
__Accept ( "pause: " )
RETURN NIL

47
harbour/tests/sdf_test.prg
View File

@@ -1,50 +1,53 @@
//NOTEST
// $Id$
//
/*
* $Id$
*/
// Test program for COPY TO SDF and APPEND FROM SDF
// Note: Only COPY TO SDF is fully implemented at this time...
// Test program for COPY TO SDF and APPEND FROM SDF
// Note: Only COPY TO SDF is fully implemented at this time...
/* Harbour Project source code
http://harbour-project.org/
Donated to the public domain on 2001-04-18 by David G. Holm <dholm@jsd-llc.com>
*/
procedure main()
local ncount := 0
use test new
PROCEDURE Main()
LOCAL ncount := 0
USE test NEW
// Copy all records and fields.
copy to test1 SDF
COPY TO test1 SDF
// Copy only address fields for records with salary over 50,000.
copy field first,last,street,city,state,zip to test2 SDF for _field->salary>50000
COPY FIELD first, last, street, city, state, zip TO test2 SDF for _field->salary > 50000
// Only copy record 3.
copy record 3 to test3 SDF
COPY record 3 TO test3 SDF
// Copy records 4 through 7.
copy next 4 to test4 SDF
COPY next 4 TO test4 SDF
// Try to copy 10 records, starting 5 records from EOF, using WHILE
go bottom
GO BOTTOM
skip -4
copy while ncount++ < 9 to test4a SDF
COPY WHILE ncount++ < 9 TO test4a SDF
// Copy the last 10 records.
go bottom
GO BOTTOM
skip -9
copy rest to test5 SDF
COPY REST TO test5 SDF
// Copy the last 10 records again.
go bottom
GO BOTTOM
skip -9
copy to test6 SDF while !eof()
COPY TO test6 SDF WHILE !EOF()
// Copy only some of the last 10 records.
go bottom
GO BOTTOM
skip -9
copy rest to test7 SDF for _field->married
COPY REST TO test7 SDF for _field->married
// Try to append from a file that we know does not exist.
delete file test8.txt
append from test8 SDF
quit
DELETE file test8.txt
APPEND FROM test8 SDF
QUIT

27
harbour/tests/seconds.prg
View File

@@ -8,22 +8,23 @@
Donated to the public domain on 2001-03-08 by David G. Holm <dholm@jsd-llc.com>
*/
function Main( cParam )
local n, limit := 10
FUNCTION Main( cParam )
IF ! EMPTY( cParam )
limit := VAL( cParam )
LOCAL n, limit := 10
IF ! Empty( cParam )
limit := Val( cParam )
ENDIF
OUTSTD( hb_eol() )
OUTSTD( SECONDS() )
OutStd( hb_eol() )
OutStd( Seconds() )
FOR n := 1 TO limit
IF EMPTY( cParam )
OUTSTD( hb_eol() )
OUTSTD( "Pause: " )
INKEY(0)
IF Empty( cParam )
OutStd( hb_eol() )
OutStd( "Pause: " )
Inkey( 0 )
ENDIF
OUTSTD( hb_eol() )
OUTSTD( SECONDS() )
OutStd( hb_eol() )
OutStd( Seconds() )
NEXT
RETURN NIL
RETURN NIL

8
harbour/tests/server.prg
View File

@@ -118,13 +118,13 @@ PROCEDURE Progress( nProgress, nDrow, nDcol )
DO CASE
CASE nProgress == 0
@ nDrow, nDcol + 1 SAY "-"
@ nDrow, nDcol + 1 SAY "-"
CASE nProgress == 1
@ nDrow, nDcol + 1 SAY "\"
@ nDrow, nDcol + 1 SAY "\"
CASE nProgress == 2
@ nDrow, nDcol + 1 SAY "|"
@ nDrow, nDcol + 1 SAY "|"
CASE nProgress == 3
@ nDrow, nDcol + 1 SAY "/"
@ nDrow, nDcol + 1 SAY "/"
ENDCASE
nProgress++

15
harbour/tests/set_num.prg
View File

@@ -6,12 +6,13 @@
#include "set.ch"
function Main()
local n
PROCEDURE Main()
for n := 1 to _SET_COUNT
outstd (hb_eol())
outstd (set (n))
next
LOCAL n
return nil
FOR n := 1 TO _SET_COUNT
OutStd( hb_eol() )
OutStd( Set( n ) )
NEXT
RETURN

137
harbour/tests/set_test.prg
View File

@@ -5,86 +5,91 @@
// Testing SET
#include "set.ch"
request dbfntx
function Main()
// for Clipper, this drags in the terminal driver
@ Row(), col() say ""
TestLine( "_SET_EXACT", 1)
TestLine( "_SET_FIXED", 2)
TestLine( "_SET_DECIMALS", 3)
TestLine( "_SET_DATEFORMAT", 4)
TestLine( "_SET_EPOCH", 5)
TestLine( "_SET_PATH", 6)
TestLine( "_SET_DEFAULT", 7)
REQUEST dbfntx
TestLine( "_SET_EXCLUSIVE", 8)
TestLine( "_SET_SOFTSEEK", 9)
TestLine( "_SET_UNIQUE", 10)
TestLine( "_SET_DELETED", 11)
FUNCTION Main()
TestLine( "_SET_CANCEL", 12)
TestLine( "_SET_DEBUG", 13)
TestLine( "_SET_TYPEAHEAD", 14)
// for Clipper, this drags in the terminal driver
@ Row(), Col() SAY ""
TestLine( "_SET_COLOR", 15)
TestLine( "_SET_CURSOR", 16)
TestLine( "_SET_CONSOLE", 17)
TestLine( "_SET_ALTERNATE", 18)
TestLine( "_SET_ALTFILE", 19)
TestLine( "_SET_DEVICE", 20)
TestLine( "_SET_EXTRA", 21)
TestLine( "_SET_EXTRAFILE", 22)
TestLine( "_SET_PRINTER", 23)
TestLine( "_SET_PRINTFILE", 24)
TestLine( "_SET_MARGIN", 25)
TestLine( "_SET_EXACT", 1 )
TestLine( "_SET_FIXED", 2 )
TestLine( "_SET_DECIMALS", 3 )
TestLine( "_SET_DATEFORMAT", 4 )
TestLine( "_SET_EPOCH", 5 )
TestLine( "_SET_PATH", 6 )
TestLine( "_SET_DEFAULT", 7 )
TestLine( "_SET_BELL", 26)
TestLine( "_SET_CONFIRM", 27)
TestLine( "_SET_ESCAPE", 28)
TestLine( "_SET_INSERT", 29)
TestLine( "_SET_EXIT", 30)
TestLine( "_SET_INTENSITY", 31)
TestLine( "_SET_SCOREBOARD", 32)
TestLine( "_SET_DELIMITERS", 33)
TestLine( "_SET_DELIMCHARS", 34)
TestLine( "_SET_EXCLUSIVE", 8 )
TestLine( "_SET_SOFTSEEK", 9 )
TestLine( "_SET_UNIQUE", 10 )
TestLine( "_SET_DELETED", 11 )
TestLine( "_SET_WRAP", 35)
TestLine( "_SET_MESSAGE", 36)
TestLine( "_SET_MCENTER", 37)
TestLine( "_SET_SCROLLBREAK", 38)
TestLine( "_SET_CANCEL", 12 )
TestLine( "_SET_DEBUG", 13 )
TestLine( "_SET_TYPEAHEAD", 14 )
TestLine( "_SET_COLOR", 15 )
TestLine( "_SET_CURSOR", 16 )
TestLine( "_SET_CONSOLE", 17 )
TestLine( "_SET_ALTERNATE", 18 )
TestLine( "_SET_ALTFILE", 19 )
TestLine( "_SET_DEVICE", 20 )
TestLine( "_SET_EXTRA", 21 )
TestLine( "_SET_EXTRAFILE", 22 )
TestLine( "_SET_PRINTER", 23 )
TestLine( "_SET_PRINTFILE", 24 )
TestLine( "_SET_MARGIN", 25 )
TestLine( "_SET_BELL", 26 )
TestLine( "_SET_CONFIRM", 27 )
TestLine( "_SET_ESCAPE", 28 )
TestLine( "_SET_INSERT", 29 )
TestLine( "_SET_EXIT", 30 )
TestLine( "_SET_INTENSITY", 31 )
TestLine( "_SET_SCOREBOARD", 32 )
TestLine( "_SET_DELIMITERS", 33 )
TestLine( "_SET_DELIMCHARS", 34 )
TestLine( "_SET_WRAP", 35 )
TestLine( "_SET_MESSAGE", 36 )
TestLine( "_SET_MCENTER", 37 )
TestLine( "_SET_SCROLLBREAK", 38 )
#ifdef _SET_EVENTMASK
TestLine( "_SET_EVENTMASK", 39)
TestLine( "_SET_EVENTMASK", 39 )
TestLine( "_SET_VIDEOMODE", 40)
TestLine( "_SET_VIDEOMODE", 40 )
TestLine( "_SET_MBLOCKSIZE", 41)
TestLine( "_SET_MFILEEXT", 42)
TestLine( "_SET_MBLOCKSIZE", 41 )
TestLine( "_SET_MFILEEXT", 42 )
TestLine( "_SET_STRICTREAD", 43)
TestLine( "_SET_OPTIMIZE", 44)
TestLine( "_SET_AUTOPEN", 45)
TestLine( "_SET_AUTORDER", 46)
TestLine( "_SET_AUTOSHARE", 47)
TestLine( "_SET_STRICTREAD", 43 )
TestLine( "_SET_OPTIMIZE", 44 )
TestLine( "_SET_AUTOPEN", 45 )
TestLine( "_SET_AUTORDER", 46 )
TestLine( "_SET_AUTOSHARE", 47 )
#endif
#ifdef _SET_LANGUAGE
TestLine( "_SET_LANGUAGE", 100)
TestLine( "_SET_IDLEREPEAT", 101)
TestLine( "_SET_FILECASE", 102)
TestLine( "_SET_DIRCASE", 103)
TestLine( "_SET_DIRSEPARATOR",104)
Set(_SET_DIRSEPARATOR, "/")
TestLine( "_SET_DIRSEPARATOR",104)
TestLine( "_SET_LANGUAGE", 100 )
TestLine( "_SET_IDLEREPEAT", 101 )
TestLine( "_SET_FILECASE", 102 )
TestLine( "_SET_DIRCASE", 103 )
TestLine( "_SET_DIRSEPARATOR", 104 )
SET( _SET_DIRSEPARATOR, "/" )
TestLine( "_SET_DIRSEPARATOR", 104 )
#endif
return nil
RETURN NIL
proc testline( c, n )
outstd( hb_eol() )
outstd( str( n, 3 ) )
outstd( " " )
outstd( Padr( c, 20 ) )
outstd( Set( n ) )
return
PROCEDURE testline( c, n )
OutStd( hb_eol() )
OutStd( Str( n, 3 ) )
OutStd( " " )
OutStd( PadR( c, 20 ) )
OutStd( Set( n ) )
RETURN

113
harbour/tests/setkeys.prg
View File

@@ -55,77 +55,80 @@
#include "inkey.ch"
Procedure Main()
local GetList := {}
local alpha, bravo, charlie, k, l
local F8Active := .t.
PROCEDURE Main()
cls
LOCAL GetList := {}
LOCAL alpha, bravo, charlie, k, l
LOCAL F8Active := .T.
@ 2, 2 say "Press F10 to popup alert box of current get, not active if empty"
@ 3, 2 say "Press F9 to disable all setkeys, except F9 to restore (uses SetKeySave())"
@ 4, 2 say "Press F8 to test setkey w/ array, SetKeyCheck(), and SetKeyGet()"
@ 5, 2 say "Press F7 to active/deactive F8"
CLS
alpha := "alpha "
bravo := 123
charlie := date()
@ 2, 2 SAY "Press F10 to popup alert box of current get, not active if empty"
@ 3, 2 SAY "Press F9 to disable all setkeys, except F9 to restore (uses SetKeySave())"
@ 4, 2 SAY "Press F8 to test setkey w/ array, SetKeyCheck(), and SetKeyGet()"
@ 5, 2 SAY "Press F7 to active/deactive F8"
@ 10, 10 get alpha
@ 11, 10 get bravo
@ 12, 10 get charlie
alpha := "alpha "
bravo := 123
charlie := Date()
#ifndef K_F10
@ 10, 10 GET alpha
@ 11, 10 GET bravo
@ 12, 10 GET charlie
#define K_F10 -9
#define K_F9 -8
#define K_F8 -7
#define K_ESC 27
#ifndef K_F10
#endif
#define K_F10 -9
#define K_F9 -8
#define K_F8 -7
#define K_ESC 27
setKey( K_F10, {|| Alert( transform( getactive():varGet(), NIL ) ) }, ;
{|| !empty( getactive():VarGet() ) } ) /* :buffer */
setKey( K_F9 , {|| k := hb_SetKeySave( NIL ), ;
SetKey( K_F9, {|| hb_SetKeySave( k ) } ) } )
SetKey( K_F8 , {|| SubMain() }, {|| F8Active } )
SetKey( K_F7 , {|| F8Active := ! F8Active } )
#endif
read
? alpha, bravo, charlie
SetKey( K_F10, { || Alert( Transform( GetActive():varGet(), NIL ) ) }, ;
{ || !Empty( GetActive():VarGet() ) } ) /* :buffer */
SetKey( K_F9 , { || k := hb_SetKeySave( NIL ), ;
SetKey( K_F9, { || hb_SetKeySave( k ) } ) } )
SetKey( K_F8 , { || SubMain() }, { || F8Active } )
SetKey( K_F7 , { || F8Active := ! F8Active } )
return
READ
? alpha, bravo, charlie
static Procedure SubMain()
local n
local bF8Action, bF8Active
RETURN
bF8Action := hb_SetKeyGet( K_F8, @bF8Active )
SetKey( K_F8, NIL )
STATIC PROCEDURE SubMain()
hb_SetKeyArray( { 49, 50, 52, 53 }, {|x| qout( chr( x ) ) } )
do while ( n := inkey( 0 ) ) != K_ESC
if hb_SetKeyCheck( n, procname(),procline(), readvar() )
qqout( " hit hot" )
else
qout( chr( n ) )
qqout( " hit cold" )
endif
end
LOCAL n
LOCAL bF8Action, bF8Active
hb_SetKeyArray( { 49, 50, 52, 53 }, NIL )
SetKey( K_F8, bF8Action, bF8Active )
bF8Action := hb_SetKeyGet( K_F8, @bF8Active )
SetKey( K_F8, NIL )
return
hb_SetKeyArray( { 49, 50, 52, 53 }, { |x| QOut( Chr( x ) ) } )
DO WHILE ( n := Inkey( 0 ) ) != K_ESC
IF hb_SetKeyCheck( n, ProcName(), ProcLine(), ReadVar() )
QQOut( " hit hot" )
ELSE
QOut( Chr( n ) )
QQOut( " hit cold" )
ENDIF
end
Procedure Help( cProc, nLine, cVar )
local nX := col(), nY := row()
hb_SetKeyArray( { 49, 50, 52, 53 }, NIL )
SetKey( K_F8, bF8Action, bF8Active )
@ 19, 19 say "Pcount: " ; ?? pcount()
@ 20, 10 say "Proc : " ; ?? cProc
@ 21, 10 say "Line : " ; ?? nLine
@ 22, 10 say "Var : " ; ?? cVar
RETURN
SetPos( nX, nY )
PROCEDURE Help( cProc, nLine, cVar )
return
LOCAL nX := Col(), nY := Row()
@ 19, 19 SAY "Pcount: " ; ?? PCount()
@ 20, 10 SAY "Proc : " ; ?? cProc
@ 21, 10 SAY "Line : " ; ?? nLine
@ 22, 10 SAY "Var : " ; ?? cVar
SetPos( nX, nY )
RETURN

23
harbour/tests/sound.prg
View File

@@ -2,13 +2,16 @@
* $Id$
*/
function main()
local start := seconds(), stop
qout( "start ", start )
tone( 440, 9.1 )
tone( 880, 9.1 )
tone( 440, 9.1 )
stop := seconds()
qout( "stop ", stop )
qout( "duration", ( stop - start ), "(should be close to 1.5)" )
return nil
PROCEDURE Main()
LOCAL start := Seconds(), stop
QOut( "start ", start )
Tone( 440, 9.1 )
Tone( 880, 9.1 )
Tone( 440, 9.1 )
stop := Seconds()
QOut( "stop ", stop )
QOut( "duration", ( stop - start ), "(should be close to 1.5)" )
RETURN

33
harbour/tests/speed.prg
View File

@@ -2,22 +2,25 @@
* $Id$
*/
Function Main()
Local Program := { , }, Condition := 1, body := 2, Counter := 1, TheEnd := 1000000, stop, start
PROCEDURE Main()
Program[ condition] := { || Counter == TheEnd}
Program[ body] := { || Counter++}
? start := Second()
LOCAL Program := { , }, Condition := 1, body := 2, Counter := 1, TheEnd := 1000000, stop, start
// in Clipper :
// While !Program[ condition]:Eval() ; Program[ body]:Eval()
// why Harbour CodeBlocks don't have Eval() method ?!
Program[ condition] := {|| Counter == TheEnd }
Program[ body] := {|| Counter ++ }
? start := Second()
// Now It is supported.
// in Clipper :
// While !Program[ condition]:Eval() ; Program[ body]:Eval()
// why Harbour CodeBlocks don't have Eval() method ?!
While !Eval( Program[ condition]) ; Eval( Program[ body])
End
? stop := Second()
? '==============='
? stop - start
Return NIL
// Now It is supported.
DO WHILE ! Eval( Program[ condition] )
Eval( Program[ body] )
ENDDO
? stop := Second()
? '==============='
? stop - start
RETURN

14
harbour/tests/statfun.prg
View File

@@ -1,10 +1,10 @@
//
// $Id$
//
/*
* $Id$
*/
// Testing a static function call
function Main()
PROCEDURE Main()
QOut( "From Main()" )
@@ -12,10 +12,10 @@ function Main()
QOut( "From Main() again" )
return nil
RETURN
static function SecondOne()
STATIC FUNCTION SecondOne()
QOut( "From Second()" )
return nil
RETURN nil

68
harbour/tests/statics.prg
View File

@@ -1,15 +1,16 @@
//
// $Id$
//
/*
* $Id$
*/
// Testing Harbour statics variables management
static z := "First"
STATIC s_z := "First"
function Main()
LOCAL i, cb
PROCEDURE Main()
static a := "Hello", b := { 1, 2, 3, 4, 5, 6, 7, 8, 9, 10 }
LOCAL i, cb
STATIC a := "Hello", b := { 1, 2, 3, 4, 5, 6, 7, 8, 9, 10 }
QOut( a )
QOut( b[ 2 ] )
@@ -18,43 +19,48 @@ LOCAL i, cb
QOut( "Ok!" )
FOR i:=1 TO 10
NumStat()
NEXT
cb :=DetachVar( 10 )
FOR i:=1 To 10
QOut( EVAL( cb, b[ i ] ) )
FOR i := 1 TO 10
NumStat()
NEXT
return nil
cb := DetachVar( 10 )
FOR i := 1 TO 10
QOut( Eval( cb, b[ i ] ) )
NEXT
function Two()
RETURN
static a := "Test"
FUNCTION Two()
STATIC a := "Test"
QOut( a )
return nil
RETURN NIL
FUNCTION THREE( p )
QOut( p )
RETURN p
PROCEDURE NumStat(a)
STATIC n:=1
LOCAL cb
//STATIC m:=n //uncomment it to see an error
//STATIC m:=Time() //uncomment it to see an error
RETURN p
cb :={|x| z +STR(x)}
QOut( ++n )
QOut( EVAL( cb,n ) )
RETURN
PROCEDURE NumStat( a )
STATIC s_n := 1
LOCAL cb
// STATIC m := s_n // uncomment it to see an error
// STATIC m := Time() // uncomment it to see an error
cb := {| x | s_z + Str( x ) }
QOut( ++s_n )
QOut( Eval( cb, s_n ) )
RETURN
FUNCTION DetachVar( xLocal )
STATIC xStatic:=100
RETURN( {|x| ++xStatic, x+xStatic+xLocal} )
STATIC xStatic := 100
RETURN( {| x | ++xStatic, x + xStatic + xLocal } )

12
harbour/tests/statics1.prg
View File

@@ -1,14 +1,14 @@
//
// $Id$
//
/*
* $Id$
*/
// Statics overlapped!
//
// Compile statics1.prg, statics2.prg and link both files
static uOne, uTwo
STATIC uOne, uTwo
function Main()
PROCEDURE Main()
QOut( "Statics overlapped!" )
QOut( "===================" )
@@ -28,4 +28,4 @@ function Main()
QOut( " uOne, uTwo =>", uOne, ",", uTwo )
QOut( "" )
return nil
RETURN

12
harbour/tests/statics2.prg
View File

@@ -1,14 +1,14 @@
//
// $Id$
//
/*
* $Id$
*/
// Statics overlapped!
//
// Compile statics1.prg, statics2.prg and link both files
static uA, uB
STATIC uA, uB
function Test()
PROCEDURE Test()
QOut( "INSIDE statics2.prg" )
QOut( " static uA, uB" )
@@ -22,4 +22,4 @@ function Test()
QOut( " uA, uB =>", uA, ",", uB )
QOut( "" )
return nil
RETURN

10
harbour/tests/statinit.prg
View File

@@ -1,6 +1,6 @@
//
// $Id$
//
/*
* $Id$
*/
// ; Donated to the public domain by
// Viktor Szakats (harbour syenar.net)
@@ -10,14 +10,14 @@ MEMVAR cMyPubVar
STATIC bBlock1 := {|| Hello() }
STATIC bBlock2 := {|| cMyPubVar }
FUNCTION Main()
PROCEDURE Main()
PUBLIC cMyPubVar := "Printed from a PUBLIC var from a codeblock assigned to a static variable."
Eval( bBlock1 )
? Eval( bBlock2 )
RETURN NIL
RETURN
FUNCTION Hello()

18
harbour/tests/strdelim.prg
View File

@@ -1,14 +1,14 @@
//
// $Id$
//
/*
* $Id$
*/
procedure main()
PROCEDURE Main()
local aArray := {{NIL}}
LOCAL aArray := { { NIL } }
aArray [ 1 /*first*/ ][ 1 /* second */ ] := [Hello]
aArray[ 1 /*first*/ ][ 1 /* second */ ] := [Hello]
QOut( aArray[1][1] )
QOut( aArray[ 1 ][ 1 ] )
QOut( 'World "Peace[!]"' )
@@ -16,6 +16,4 @@ procedure main()
QOut( [King 'Clipper "!"'] )
return
RETURN

54
harbour/tests/stripem.prg
View File

@@ -4,7 +4,7 @@
#include "set.ch"
#xtranslate Default( <Var>, <xVal> ) => IIF( <Var> == NIL, <xVal>, <Var> )
#xtranslate Default( <Var>, <xVal> ) => iif( <Var> == NIL, <xVal>, <Var> )
//
// Strip
@@ -56,9 +56,9 @@ FUNCTION Main( cFrom, cTo )
RETURN nil
//
// Generic DOS file handler
//
//
// Generic DOS file handler
//
FUNCTION TTextFile() // Parameter = dirty
@@ -94,13 +94,13 @@ FUNCTION TTextFile() // Parameter = dirty
RETURN oFile:Instance()
//
// Method TextFile:New -> Create a new text file
//
// <cFile> file name. No wild characters
// <cMode> mode for opening. Default "R"
// <nBlockSize> Optional maximum blocksize
//
//
// Method TextFile:New -> Create a new text file
//
// <cFile> file name. No wild characters
// <cMode> mode for opening. Default "R"
// <nBlockSize> Optional maximum blocksize
//
FUNCTION New( cFileName, cMode, nBlock )
@@ -129,9 +129,9 @@ FUNCTION New( cFileName, cMode, nBlock )
RETURN self
//
// Dispose -> Close the file handle
//
//
// Dispose -> Close the file handle
//
FUNCTION Dispose()
@@ -150,9 +150,9 @@ FUNCTION Dispose()
RETURN self
//
// Read a single line
//
//
// Read a single line
//
FUNCTION READ()
@@ -204,13 +204,13 @@ FUNCTION READ()
RETURN cRet
//
// WriteLn -> Write a line to a file
//
// <xTxt> Text to write. May be any type. May also be an array containing
// one or more strings
// <lCRLF> End with Carriage Return/Line Feed (Default == TRUE)
//
//
// WriteLn -> Write a line to a file
//
// <xTxt> Text to write. May be any type. May also be an array containing
// one or more strings
// <lCRLF> End with Carriage Return/Line Feed (Default == TRUE)
//
FUNCTION WriteLn( xTxt, lCRLF )
@@ -235,9 +235,9 @@ FUNCTION WriteLn( xTxt, lCRLF )
RETURN self
//
// Go to a specified line number
//
//
// Go to a specified line number
//
FUNCTION GOTO( nLine )

24
harbour/tests/switch.prg
View File

@@ -2,15 +2,15 @@
* $Id$
*/
#ifdef __XHARBOUR__
#ifdef __XHARBOUR__
#define OTHERWISE DEFAULT
#endif
#endif
PROCEDURE MAIN
LOCAL a:=1
PRIVATE b:="b"
PROCEDURE Main()
LOCAL a := 1
PRIVATE b := "b"
#ifndef __XHARBOUR__
#ifndef __XHARBOUR__
SWITCH a
END
#endif
@@ -43,11 +43,11 @@ PRIVATE b:="b"
? "other"
END
#ifndef __XHARBOUR__
#ifndef __XHARBOUR__
?
? "44444444444444444444444444444444444"
SWITCH a
OTHERWISE
OTHERWISE
? "OTHERWISE"
END
#endif
@@ -55,12 +55,12 @@ PRIVATE b:="b"
?
? "55555555555555555555555555555555555"
a := 'EE'
#ifndef __XHARBOUR__
#ifndef __XHARBOUR__
SWITCH a
CASE 11
? "11"
exit
CASE 'CCCC'+'DDDD'
? a+a
EXIT
@@ -71,7 +71,7 @@ PRIVATE b:="b"
CASE 1+1+1
? "3"
EXIT
CASE 1+1*3
CASE 123+12*4-1*4+2
CASE 1-4
@@ -117,4 +117,4 @@ PRIVATE b:="b"
? "========================================="
RETURN
RETURN

8
harbour/tests/symbolt.prg
View File

@@ -5,9 +5,9 @@
// Class(y) Class Symbol documentation is located at:
// http://www.clipx.net/ng/classy/ngdebc.php
function Main()
PROCEDURE Main()
local oSym := Symbol():New( "QOUT" )
LOCAL oSym := SYMBOL():New( "QOUT" )
? "Now test the :Exec() method"
@@ -19,9 +19,9 @@ function Main()
? "symbol name: ", oSym:name
? "Comparing QOut symbol with xOut symbol"
? oSym:IsEqual( Symbol():New( "xOut" ) )
? oSym:IsEqual( SYMBOL():New( "xOut" ) )
? "done!"
?
return nil
RETURN

24
harbour/tests/t1.prg
View File

@@ -1,18 +1,18 @@
//
// $Id$
//
/*
* $Id$
*/
// while loop test
function Main()
FUNCTION Main()
local i := 0
local cb := {|| QOut("test")}
LOCAL i := 0
LOCAL cb := {|| QOut( "test" ) }
while i < 1000
QOut(i)
eval(cb)
i++
end
WHILE i < 1000
QOut( i )
Eval( cb )
i ++
END
return nil
RETURN nil

2
harbour/tests/tb1.prg
View File

@@ -16,7 +16,7 @@
#include "setcurs.ch"
#include "box.ch"
proc main()
procedure Main()
static s_nCount := 0
static s_nPos := 1

16
harbour/tests/test10.prg
View File

@@ -1,16 +0,0 @@
//NOTEST
//
// $Id$
//
// compile this using Harbour /10 flag
Function Main()
QOut( MyReplicatZZ( 'a', 10 ) )
return NIL
Function MyReplicator( cChar, nLen )
return Replicate( cChar, nLen )

9
harbour/tests/testbrdb.prg
View File

@@ -4,16 +4,17 @@
// Testing Browse()
function Main()
PROCEDURE Main()
LOCAL cColor
cColor := SETCOLOR("W+/B")
cColor := SetColor( "W+/B" )
CLS
USE test
Browse()
SETCOLOR(cColor)
SetColor( cColor )
CLS
return nil
RETURN

8
harbour/tests/testbrw.prg
View File

@@ -2,7 +2,7 @@
* $Id$
*/
// Harbour Class TBrowse and TBColumn sample
// Harbour Class TBrowse and TBColumn sample
#include "inkey.ch"
@@ -58,7 +58,7 @@ FUNCTION Main()
nCol := Col()
@ 4, 4, 17, 31 BOX "ÚÄ¿³ÙÄÀ³ "
#ifdef HB_COMPAT_C53
oBrowse:SetKey( 0, { |ob, nkey| Defproc( ob,nKey ) } )
oBrowse:SetKey( 0, {| ob, nkey | Defproc( ob,nKey ) } )
WHILE .T.
oBrowse:ForceStable()
IF ( oBrowse:applykey( Inkey(0 ) ) == - 1 )
@@ -125,7 +125,7 @@ FUNCTION Main()
DevPos( nTmpRow, nTmpCol )
ENDCASE
end
#endif
DevPos( nRow, nCol )
@@ -136,7 +136,7 @@ FUNCTION Main()
#ifdef HB_COMPAT_C53
FUNCTION defproc( ob, nkey )
FUNCTION defproc( ob, nkey )
LOCAL nTmpRow, nTmpCol

66
harbour/tests/testcdx.prg
View File

@@ -1,51 +1,51 @@
//
// $Id$
//
/*
* $Id$
*/
function Main()
PROCEDURE Main()
local aStruct := { { "CHARACTER", "C", 25, 0 }, ;
{ "NUMERIC", "N", 8, 0 }, ;
{ "DOUBLE", "N", 8, 2 }, ;
{ "DATE", "D", 8, 0 }, ;
{ "MEMO", "M", 10, 0 }, ;
{ "LOGICAL", "L", 1, 0 } }
LOCAL aStruct := {;
{ "CHARACTER", "C", 25, 0 }, ;
{ "NUMERIC", "N", 8, 0 }, ;
{ "DOUBLE", "N", 8, 2 }, ;
{ "DATE", "D", 8, 0 }, ;
{ "MEMO", "M", 10, 0 }, ;
{ "LOGICAL", "L", 1, 0 } }
CLS
dbUseArea( .T., "DBFCDX", "test", "TESTDBF", .T., .F. )
dbCreate( "testcdx", aStruct, "DBFCDX", .T., "TESTCDX" )
dbUseArea( .T. , "DBFCDX", "test", "TESTDBF", .T. , .F. )
dbCreate( "testcdx", aStruct, "DBFCDX", .T. , "TESTCDX" )
? "RddName:", RddName()
// ? "Press any key to continue..."
// InKey( 0 )
? "RddName:", rddName()
// ? "Press any key to continue..."
// InKey( 0 )
Select( "TESTDBF" )
SET FILTER TO TESTDBF->SALARY > 140000
TESTDBF->( dbGoTop() )
// while !TESTDBF->( Eof() )
// TESTCDX->( dbAppend() )
// TESTCDX->CHARACTER = TESTDBF->FIRST
// TESTCDX->NUMERIC = TESTDBF->SALARY
// TESTCDX->MEMO := TESTDBF->FIRST + Chr( 13 ) + Chr( 10 ) + ;
// TESTDBF->LAST + Chr( 13 ) + Chr( 10 ) + ;
// TESTDBF->STREET
// TESTDBF->( dbSkip() )
// end
// WHILE !TESTDBF->( Eof() )
// TESTCDX->( dbAppend() )
// TESTCDX->CHARACTER = TESTDBF->FIRST
// TESTCDX->NUMERIC = TESTDBF->SALARY
// TESTCDX->MEMO := TESTDBF->FIRST + Chr( 13 ) + Chr( 10 ) + ;
// TESTDBF->LAST + Chr( 13 ) + Chr( 10 ) + ;
// TESTDBF->STREET
// TESTDBF->( dbSkip() )
// ENDDO
? TESTCDX->( RecCount() )
TESTCDX->( dbGoTop() )
? TESTCDX->( Eof() )
while !TESTCDX->( Eof() )
? TESTCDX->( EOF() )
WHILE !TESTCDX->( EOF() )
? TESTCDX->( RecNo() ), TESTCDX->NUMERIC
? TESTCDX->MEMO
TESTCDX->( dbSkip() )
// ? "Press any key to continue..."
// InKey( 0 )
end
// ? "Press any key to continue..."
// InKey( 0 )
ENDDO
FErase( "testcdx.cdx" )
Select( "TESTCDX" )
OrdCreate( "testcdx", "Character", "CHARACTER", FIELD->CHARACTER, .F. )
SELECT( "TESTCDX" )
ordCreate( "testcdx", "Character", "CHARACTER", FIELD->CHARACTER, .F. )
return nil
RETURN

19
harbour/tests/testcls.prg
View File

@@ -6,18 +6,19 @@
#include "hbclass.ch"
function Main()
PROCEDURE Main()
local o := Test()
LOCAL o := Test()
o:Another( "Hello" ) // "Another" message is not defined for Class Test, but
// it will invoke ON ERROR MyErrorManager() method
// it will invoke ON ERROR MyErrorManager() method
o:Another := 5 // Notice how __GetMessage() shows a underscored message
// as we are setting a DATA value.
return nil
// as we are setting a DATA value.
CLASS Test
RETURN
CREATE CLASS Test
ON ERROR MyErrorManager( uParam1 )
@@ -25,10 +26,10 @@ ENDCLASS
METHOD MyErrorManager( uParam1 ) CLASS Test
if PCount() > 0
IF PCount() > 0
Alert( uParam1 )
endif
ENDIF
Alert( __GetMessage() ) // Shows the message that was sent to the object
return nil
RETURN nil

119
harbour/tests/testdbf.prg
View File

@@ -2,19 +2,19 @@
* $Id$
*/
function main()
PROCEDURE Main()
local nI, aStruct := { { "CHARACTER", "C", 25, 0 }, ;
{ "NUMERIC", "N", 8, 0 }, ;
{ "DOUBLE", "N", 8, 2 }, ;
{ "DATE", "D", 8, 0 }, ;
{ "LOGICAL", "L", 1, 0 }, ;
{ "MEMO1", "M", 10, 0 }, ;
{ "MEMO2", "M", 10, 0 } }
LOCAL nI, aStruct := { { "CHARACTER", "C", 25, 0 }, ;
{ "NUMERIC", "N", 8, 0 }, ;
{ "DOUBLE", "N", 8, 2 }, ;
{ "DATE", "D", 8, 0 }, ;
{ "LOGICAL", "L", 1, 0 }, ;
{ "MEMO1", "M", 10, 0 }, ;
{ "MEMO2", "M", 10, 0 } }
REQUEST DBFCDX
dbCreate( "testdbf", aStruct, "DBFCDX", .t., "MYALIAS" )
dbCreate( "testdbf", aStruct, "DBFCDX", .T. , "MYALIAS" )
? "[" + MYALIAS->MEMO1 + "]"
? "[" + MYALIAS->MEMO2 + "]"
@@ -36,25 +36,25 @@ function main()
? ""
? "Press any key..."
InKey( 0 )
Inkey( 0 )
? ""
? "Append 50 records with memos..."
for nI := 1 to 50
FOR nI := 1 TO 50
MYALIAS->( dbAppend() )
MYALIAS->MEMO1 := "This is a very long string. " + ;
"This may seem silly however strings like this are still " + ;
"used. Not by good programmers though, but I've seen " + ;
"stuff like this used for Copyright messages and other " + ;
"long text. What is the point to all of this you'd say. " + ;
"Well I am coming to the point right now, the constant " + ;
"string is limited to 256 characters and this string is " + ;
"a lot bigger. Do you get my drift ? If there is somebody " + ;
"who has read this line upto the very end: Esto es un " + ;
"sombrero grande rid¡culo." + Chr( 13 ) + Chr( 10 ) + ;
"/" + Chr( 13 ) + Chr( 10 ) + "[;-)" + Chr( 13 ) + Chr( 10 )+ ;
"\"
next
"This may seem silly however strings like this are still " + ;
"used. Not by good programmers though, but I've seen " + ;
"stuff like this used for Copyright messages and other " + ;
"long text. What is the point to all of this you'd say. " + ;
"Well I am coming to the point right now, the constant " + ;
"string is limited to 256 characters and this string is " + ;
"a lot bigger. Do you get my drift ? If there is somebody " + ;
"who has read this line upto the very end: Esto es un " + ;
"sombrero grande rid¡culo." + Chr( 13 ) + Chr( 10 ) + ;
"/" + Chr( 13 ) + Chr( 10 ) + "[;-)" + Chr( 13 ) + Chr( 10 ) + ;
"\"
NEXT
MYALIAS->( dbCommit() )
? "Records before ZAP:", MYALIAS->( LastRec() )
@@ -71,73 +71,73 @@ function main()
? "[" + Str( MYALIAS->DOUBLE ) + "]"
? "[" + Str( MYALIAS->NUMERIC ) + "]"
? "Press any key..."
InKey( 0 )
Inkey( 0 )
dbCloseAll()
dbCreate( "testdbf", aStruct,, .t., "MYALIAS" )
dbCreate( "testdbf", aStruct, , .T. , "MYALIAS" )
for nI := 1 to 10
FOR nI := 1 TO 10
MYALIAS->( dbAppend() )
MYALIAS->NUMERIC := nI
? "Adding a record", nI
if nI == 3 .or. nI == 7
IF nI == 3 .OR. nI == 7
MYALIAS->( dbDelete() )
? "Deleting record", nI
endif
next
ENDIF
NEXT
MYALIAS->( dbCommit() )
? ""
? "With SET DELETED OFF"
? "Press any key..."
InKey( 0 )
Inkey( 0 )
MYALIAS->( dbGoTop() )
do while !MYALIAS->( Eof() )
DO WHILE !MYALIAS->( EOF() )
? MYALIAS->NUMERIC
MYALIAS->( dbSkip() )
enddo
ENDDO
SET DELETED ON
? ""
? "With SET DELETED ON"
? "Press any key..."
InKey( 0 )
Inkey( 0 )
MYALIAS->( dbGoTop() )
do while !MYALIAS->( Eof() )
DO WHILE !MYALIAS->( EOF() )
? MYALIAS->NUMERIC
MYALIAS->( dbSkip() )
enddo
ENDDO
? ""
? "With SET DELETED ON"
? "and SET FILTER TO MYALIAS->NUMERIC > 2 .AND. MYALIAS->NUMERIC < 8"
? "Press any key..."
InKey( 0 )
Inkey( 0 )
MYALIAS->( dbSetFilter( { || MYALIAS->NUMERIC > 2 .AND. MYALIAS->NUMERIC < 8 }, ;
"MYALIAS->NUMERIC > 2 .AND. MYALIAS->NUMERIC < 8" ) )
"MYALIAS->NUMERIC > 2 .AND. MYALIAS->NUMERIC < 8" ) )
MYALIAS->( dbGoTop() )
do while !MYALIAS->( Eof() )
DO WHILE !MYALIAS->( EOF() )
? MYALIAS->NUMERIC
MYALIAS->( dbSkip() )
enddo
ENDDO
SET DELETED OFF
? ""
? "With SET DELETED OFF"
? "and SET FILTER TO MYALIAS->NUMERIC > 2 .AND. MYALIAS->NUMERIC < 8"
? "Press any key..."
InKey( 0 )
Inkey( 0 )
MYALIAS->( dbSetFilter( { || MYALIAS->NUMERIC > 2 .AND. MYALIAS->NUMERIC < 8 }, ;
"MYALIAS->NUMERIC > 2 .AND. MYALIAS->NUMERIC < 8" ) )
"MYALIAS->NUMERIC > 2 .AND. MYALIAS->NUMERIC < 8" ) )
MYALIAS->( dbGoTop() )
do while !MYALIAS->( Eof() )
DO WHILE !MYALIAS->( EOF() )
? MYALIAS->NUMERIC
MYALIAS->( dbSkip() )
enddo
ENDDO
? "dbFilter() => " + dbFilter()
? ""
@@ -153,34 +153,33 @@ function main()
? "Size of files (data and memo):", Directory( "testdbf.dbf" )[1][2], ;
Directory( "testdbf.dbt" )[1][2]
? "Press any key..."
InKey( 0 )
Inkey( 0 )
? "Value of fields:"
MYALIAS->( dbGoTop() )
do while !MYALIAS->( Eof() )
DO WHILE !MYALIAS->( EOF() )
? MYALIAS->NUMERIC
MYALIAS->( dbSkip() )
enddo
ENDDO
? ""
? "Open test.dbf and LOCATE FOR TESTDBF->SALARY > 145000"
? "Press any key..."
InKey( 0 )
dbUseArea( ,, "test", "TESTDBF" )
locate for TESTDBF->SALARY > 145000
do while TESTDBF->( Found() )
Inkey( 0 )
dbUseArea( , , "test", "TESTDBF" )
LOCATE for TESTDBF->SALARY > 145000
DO WHILE TESTDBF->( Found() )
? TESTDBF->FIRST, TESTDBF->LAST, TESTDBF->SALARY
continue
enddo
CONTINUE
ENDDO
? ""
? "LOCATE FOR TESTDBF->MARRIED .AND. TESTDBF->FIRST > 'S'"
? "Press any key..."
InKey( 0 )
dbUseArea( ,, "test", "TESTDBF" )
locate for TESTDBF->MARRIED .AND. TESTDBF->FIRST > 'S'
do while TESTDBF->( Found() )
Inkey( 0 )
dbUseArea( , , "test", "TESTDBF" )
LOCATE for TESTDBF->MARRIED .AND. TESTDBF->FIRST > 'S'
DO WHILE TESTDBF->( Found() )
? TESTDBF->FIRST, TESTDBF->LAST, TESTDBF->MARRIED
continue
enddo
return nil
CONTINUE
ENDDO
RETURN

69
harbour/tests/testdecl.prg
View File

@@ -1,9 +1,12 @@
/*
* $Id$
*/
// Test for DECLARE statement
// $Id$
//
#include "hbclass.ch"
#TRANSLATE AS NEW <ClassName> => AS CLASS <ClassName> := <ClassName>():New()
#translate AS NEW <ClassName> => AS CLASS <ClassName> := <ClassName>():New()
DECLARE nMyFun() AS NUMERIC
@@ -26,47 +29,47 @@ CLASS MyClass
VAR cVar AS STRING
END CLASS
INIT Function Main()
INIT PROCEDURE Main()
MEMVAR Var1, Var2, aVar
MEMVAR Var3, aVar5, aVar8, Var7
LOCAL MyObj AS NEW MyClass
MEMVAR Var1, Var2, aVar
MEMVAR Var3, aVar5, aVar8, Var7
LOCAL MyObj AS NEW MyClass
DECLARE Var1
DECLARE Var2 := 2
DECLARE aVar[2]
DECLARE Var3 := 'Var9', Var4, aVar5[1]
DECLARE Var6, Var7:=7, aVar8[8]
DECLARE Var9
DECLARE &var3
DECLARE &Var3.
DECLARE &Var3. ; DECLARE &Var3.&Var3
DECLARE &Var3.var3
DECLARE Var3&Var3
DECLARE Var3&Var3.
DECLARE Var3&Var3&Var3
DECLARE Var1
DECLARE Var2 := 2
DECLARE aVar[2]
DECLARE Var3 := 'Var9', Var4, aVar5[1]
DECLARE Var6, Var7:=7, aVar8[8]
DECLARE Var9
DECLARE &var3
DECLARE &Var3.
DECLARE &Var3. ; DECLARE &Var3.&Var3
DECLARE &Var3.var3
DECLARE Var3&Var3
DECLARE Var3&Var3.
DECLARE Var3&Var3&Var3
M->Var1 := nMyFun()
? M->Var1
M->Var1 := nMyFun()
? M->Var1
? M->Var2
? M->Var2
M->aVar[1] := 'Array Element'
? M->aVar[1]
M->aVar[1] := 'Array Element'
? M->aVar[1]
MyObj:cVar := 'Hello'
? MyObj:cVar
MyObj:cVar := 'Hello'
? MyObj:cVar
M->Var1 := MyClass():New()
? M->Var1:While
M->Var1 := MyClass():New()
? M->Var1:While
RETURN NIL
RETURN
METHOD New() CLASS MyClass
::While := 2 // TODO: Should produce RT Error.
RETURN Self
RETURN Self
Function nMyFun()
RETURN 1
FUNCTION nMyFun()
RETURN 1

12
harbour/tests/testerro.prg
View File

@@ -1,15 +1,15 @@
//
// $Id$
//
/*
* $Id$
*/
// Testing Harbour Error system
function Main()
PROCEDURE Main()
local n
LOCAL n
QOut( "We are running and now an error will raise" )
n++ // an error should raise here
return nil
RETURN

8
harbour/tests/testfor.prg
View File

@@ -1,8 +1,8 @@
//
// $Id$
//
/*
* $Id$
*/
PRCOEDURE MAIN
PRCOEDURE Main()
LOCAL i

21
harbour/tests/testget.prg
View File

@@ -2,24 +2,24 @@
* $Id$
*/
Procedure Main()
PROCEDURE Main()
LOCAL GetList := {}, cVar := "Hello"
MEMVAR aVar, nIndex, cMacro, cEarly, cEarly2, cLate
PRIVATE aVar := { "World", "Again" }, nIndex := 1, cMacro := "cEarly", cEarly := {"Early"}, cLate := "Late!", cEarly2 := {"Early2"}
PRIVATE aVar := { "World", "Again" }, nIndex := 1, cMacro := "cEarly", cEarly := { "Early" }, cLate := "Late!", cEarly2 := { "Early2" }
CLS
? "2nd GET should say 'Early'."
@ 10,10 SAY "cVar :" GET cVar PICTURE "@K!"
@ 12,10 SAY "cMacro[1] :" GET &cMacro[1]
@ 14,10 SAY "cMacro.2[1] :" GET &cMacro.2[1]
@ 16,10 SAY "cEarly[1] :" GET cEarly[1]
//@ 14,10 SAY "cMacro :" GET &(cMacro)[1]
@ 10, 10 SAY "cVar :" GET cVar PICTURE "@K!"
@ 12, 10 SAY "cMacro[1] :" GET &cMacro[1]
@ 14, 10 SAY "cMacro.2[1] :" GET &cMacro.2[1]
@ 16, 10 SAY "cEarly[1] :" GET cEarly[1]
// @ 14,10 SAY "cMacro :" GET &(cMacro)[1]
nIndex := 2
@ 18,10 SAY "aVar :" GET aVar[nIndex]
@ 20,10 SAY "Picture of GET-1:" GET GetList[1]:Picture
@ 18, 10 SAY "aVar :" GET aVar[nIndex]
@ 20, 10 SAY "Picture of GET-1:" GET GetList[1]:Picture
nIndex := 3
cMacro := "cLate"
READ
@@ -34,5 +34,4 @@ Procedure Main()
READ
*/
RETURN
RETURN

29
harbour/tests/testgt.prg
View File

@@ -1,29 +0,0 @@
//
// $Id$
//
/*
program for testing hbgt.lib
*/
function main()
qout('gt_ascpos("Harbour",1) => ' + ltrim(str(gt_ascpos("Harbour",1))) )
qout('gt_atdiff("This Is Harbour","This Is Clipper") => ' + ltrim(str(gt_atdiff("This Is Harbour","This Is Clipper"))) )
qout('gt_chareven("The_Power_Of_Harbour") => ' + gt_chareven("The_Power_Of_Harbour") )
qout('gt_charodd("The_Power_Of_Harbour") => ' + gt_charodd("The_Power_Of_Harbour") )
qout('gt_chrcount("s","she sells shells by the sea shore") => ' + ltrim(str(gt_chrcount("s","she sells shells by the sea shore"))))
qout('gt_chrtotal("sl","she sells shells by the sea shore") => ' + ltrim(str(gt_chrtotal("sl","she sells shells by the sea shore"))))
qout('gt_charmix("CLIPPER","harbour") => ' + gt_charmix("CLIPPER","harbour") )
qout('gt_asciisum("harbour") => ' + ltrim(str(gt_asciisum("harbour"))) )
qout('gt_chrfirst("Ho", "the power of Harbour") => ' + ltrim(str(gt_chrfirst("Ho", "the power of Harbour"))) )
qout('gt_strcount("the", "the cat sat on the mat") => ' + ltrim(str(gt_strcount("the", "the cat sat on the mat"))))
qout('gt_strcspn("this is a test", "as ") => ' + ltrim(str(gt_strcspn("this is a test", "as ") )) )
qout('gt_strcspn("this is a test", "elnjpq") => ' + ltrim(str(gt_strcspn("this is a test", "elnjpq"))) )
qout('gt_strDiff("the cat", "the rat") => ' + gt_strDiff("the cat", "the rat") )
qout('gt_strexpand("HARBOUR", 2,"-") => ' + gt_strexpand("HARBOUR", 2,"-"))
qout('gt_strleft("this is a test", "hsit ") => ' + ltrim(str(gt_strleft("this is a test", "hsit ")) ))
qout('gt_strpbrk("this is a test", "sa ") => ' + gt_strpbrk("this is a test", "sa ") )
qout('gt_strright("this is a test", "teas ") => ' + ltrim(str(gt_strright("this is a test", "teas "))) )
return nil

69
harbour/tests/testhrb.prg
View File

@@ -1,54 +1,55 @@
//
// $Id$
//
/*
* $Id$
*/
// see also exthrb.prg
#include "hbhrb.ch"
Procedure Main(x)
Local pHrb, cExe := "Msg2()", n
PROCEDURE Main( x )
n:=iif(x==NIL,0,val(x))
LOCAL pHrb, cExe := "Msg2()", n
? "calling Msg ... From exe here !"
Msg()
? "========================="
n := iif( x == NIL, 0, Val( x ) )
// ? "Loading('exthrb.hrb' )"
// pHrb := hb_HrbLoad("exthrb.hrb" )
? "calling Msg ... From exe here !"
Msg()
? "========================="
// ? "Loading(HB_HRB_BIND_DEFAULT,'exthrb.hrb' )"
// pHrb := hb_HrbLoad(HB_HRB_BIND_DEFAULT,"exthrb.hrb" )
// ? "Loading('exthrb.hrb' )"
// pHrb := hb_HrbLoad("exthrb.hrb" )
// ? "Loading(HB_HRB_BIND_LOCAL,'exthrb.hrb' )"
// pHrb := hb_HrbLoad(HB_HRB_BIND_LOCAL,"exthrb.hrb" )
// ? "Loading(HB_HRB_BIND_DEFAULT,'exthrb.hrb' )"
// pHrb := hb_HrbLoad(HB_HRB_BIND_DEFAULT,"exthrb.hrb" )
? "Loading("+iif(n=0,"HB_HRB_BIND_DEFAULT",iif(n=1,"HB_HRB_BIND_LOCAL","HB_HRB_BIND_OVERLOAD"))+",'exthrb.hrb' )"
pHrb := hb_HrbLoad(n,"exthrb.hrb" )
// ? "Loading(HB_HRB_BIND_LOCAL,'exthrb.hrb' )"
// pHrb := hb_HrbLoad(HB_HRB_BIND_LOCAL,"exthrb.hrb" )
? "========================="
? "Loading(" + iif( n = 0, "HB_HRB_BIND_DEFAULT", iif( n = 1,"HB_HRB_BIND_LOCAL","HB_HRB_BIND_OVERLOAD" ) ) + ",'exthrb.hrb' )"
pHrb := hb_hrbLoad( n, "exthrb.hrb" )
? "calling Msg ... DEFAULT=From exe, LOCAL=From exe, OVERLOAD=From HRB"
Msg()
? "========================="
? "========================="
? "calling Msg ... DEFAULT=From exe, LOCAL=From HRB, OVERLOAD=From HRB"
&cExe //
? "========================="
? "calling Msg ... DEFAULT=From exe, LOCAL=From exe, OVERLOAD=From HRB"
Msg()
? "========================="
hb_HrbUnload( pHrb ) // should do nothing in case of OVERLOAD
? "calling Msg ... DEFAULT=From exe, LOCAL=From HRB, OVERLOAD=From HRB"
&cExe //
? "========================="
? "calling Msg ... DEFAULT=From exe, LOCAL=From exe, OVERLOAD=From HRB"
Msg() // test unload protection when using OVERLOAD ... then .hrb not anymore unloadable
? "========================="
hb_hrbUnload( pHrb ) // should do nothing in case of OVERLOAD
? "END"
? "calling Msg ... DEFAULT=From exe, LOCAL=From exe, OVERLOAD=From HRB"
Msg() // test unload protection when using OVERLOAD ... then .hrb not anymore unloadable
? "========================="
Return
? "END"
RETURN
Function Msg()
? "Function called from Exe"
Return .T.
FUNCTION Msg()
? "Function called from Exe"
RETURN .T.

25
harbour/tests/testhtml.prg
View File

@@ -21,8 +21,8 @@ FUNCTION Main()
oHTML:SetTitle( "Harbour Power Demonstration" )
oHTML:AddHead( "Harbour" )
oHTML:AddPara( "<B>Harbour</B> is xBase at its best. Have a taste today!", "LEFT" )
oHTML:AddPara( "<B>L i n k s</B>", "CENTER" )
oHTML:AddPara( "<b>Harbour</b> is xBase at its best. Have a taste today!", "LEFT" )
oHTML:AddPara( "<b>L i n k s</b>", "CENTER" )
oHTML:AddLink( "http://harbour-project.org", "Meet the Harbour power!" )
oHTML:Generate()
@@ -39,7 +39,7 @@ FUNCTION Main()
/*---------------------------------------------------------------------------*/
FUNCTION THTML
FUNCTION THTML()
STATIC oClass
@@ -93,7 +93,7 @@ STATIC FUNCTION AddLink( cLinkTo, cLinkName )
LOCAL Self := QSelf()
::cBody := ::cBody + ;
"<A HREF='" + cLinkTo + "'>" + cLinkName + "</A>"
"<a href='" + cLinkTo + "'>" + cLinkName + "</a>"
RETURN Self
@@ -106,7 +106,7 @@ STATIC FUNCTION AddHead( cDescr )
// ???
::cBody := ::cBody + ;
"<H1>" + cDescr + "</H1>"
"<h1>" + cDescr + "</h1>"
RETURN NIL
@@ -114,13 +114,12 @@ STATIC FUNCTION AddPara( cPara, cAlign )
LOCAL Self := QSelf()
//Default( cAlign, "Left" ) // removed Patrick Mast 2000-06-07
cAlign:=iif(cAlign==NIL,"Left",cAlign) //Added Patrick Mast 2000-06-17
cAlign := iif( cAlign == NIL, "Left", cAlign ) // Added Patrick Mast 2000-06-17
::cBody := ::cBody + ;
"<P ALIGN='" + cAlign + "'>" + hb_eol() + ;
"<p align='" + cAlign + "'>" + hb_eol() + ;
cPara + hb_eol() + ;
"</P>"
"</p>"
RETURN Self
@@ -129,12 +128,12 @@ STATIC FUNCTION Generate()
LOCAL Self := QSelf()
::cContent := ;
"<HTML><HEAD>" + hb_eol() + ;
"<TITLE>" + ::cTitle + "</TITLE>" + hb_eol() + ;
"<BODY link='" + ::cLinkColor + "' " + ;
"<html><head>" + hb_eol() + ;
"<title>" + ::cTitle + "</title>" + hb_eol() + ;
"<body link='" + ::cLinkColor + "' " + ;
"vlink='" + ::cvLinkColor + "'>" + + hb_eol() + ;
::cBody + hb_eol() + ;
"</BODY></HTML>"
"</body></html>"
RETURN Self

4
harbour/tests/testidle.prg
View File

@@ -2,9 +2,7 @@
* $Id$
*/
// #include "set.ch" - Preset in pptable.c
PROCEDURE MAIN()
PROCEDURE Main()
CLS

2
harbour/tests/testmem.prg
View File

@@ -4,7 +4,7 @@
// Testing memory release
PROCEDURE main()
PROCEDURE Main()
LOCAL a, b

29
harbour/tests/testpers.prg
View File

@@ -1,14 +1,15 @@
//
// $Id$
//
/*
* $Id$
*/
// Class HBPersistent test
#include "hbclass.ch"
function Main()
PROCEDURE Main()
local oTest := Test():New()
local oTest2 := Test2():New()
LOCAL oTest := Test():New()
LOCAL oTest2 := Test2():New()
oTest:One := "hello"
oTest:Two := 123
@@ -21,22 +22,22 @@ function Main()
oTest:SaveToFile( "test.txt" ) // We save it to a file
return nil
RETURN
CLASS Test FROM HBPersistent
CREATE CLASS Test FROM HBPersistent
DATA One PROPERTY
DATA Two PROPERTY
DATA Three
DATA Four PROPERTY
VAR One PROPERTY
VAR Two PROPERTY
VAR Three
VAR Four PROPERTY
METHOD Another() INLINE { 1, { "One", "Two" }, Date() } PROPERTY
METHOD More() VIRTUAL
ENDCLASS
CLASS Test2 FROM HBPersistent
CREATE CLASS Test2 FROM HBPersistent
DATA Five PROPERTY
VAR Five PROPERTY
ENDCLASS

2
harbour/tests/testtok.prg
View File

@@ -4,7 +4,7 @@
#include "set.ch"
PROCEDURE main()
PROCEDURE Main()
LOCAL a
LOCAL i

8
harbour/tests/testwarn.prg
View File

@@ -1,6 +1,6 @@
//
// $Id$
//
/*
* $Id$
*/
// This file is OK to have warnings.
#ifdef __HARBOUR__
@@ -55,7 +55,7 @@ MEMVAR Var1 AS STRING
STATIC lGlobal AS LOGICAL
PROCEDURE MAIN( optional )
PROCEDURE Main( optional )
STATIC lStatic := 0, oMyObj As Class WrongClass

26
harbour/tests/tstalias.prg
View File

@@ -2,12 +2,12 @@
* $Id$
*/
FUNCTION Main()
PROCEDURE Main()
USE test
REPLACE Age WITH 1
? FIELD -> Age
? FIELD->Age
//REPLACE 1->Age WITH 2 // Todo: complete support in harbour.y - AliasAddInt()
//? FIELD->Age
@@ -15,14 +15,14 @@ FUNCTION Main()
//REPLACE 1.5->Age WITH 3 // Will produce "Invalid alias expression"
//? FIELD->Age
REPLACE TEST -> Age WITH 4
? FIELD -> Age
REPLACE TEST->Age WITH 4
? FIELD->Age
TEST -> Age := 5
? FIELD -> Age
TEST->Age := 5
? FIELD->Age
TEST -> ( FieldPut( FieldPos( 'AGE' ), 6 ) )
? FIELD -> Age
TEST->( FieldPut( FieldPos( 'AGE' ), 6 ) )
? FIELD->Age
dbCloseArea()
@@ -31,10 +31,10 @@ FUNCTION Main()
USE test
// ? ("0")->FIRST
? ( "B" ) -> FIRST
? ( "2" ) -> FIRST
? 2 -> FIRST
? B -> FIRST
? ( "B" )->FIRST
? ( "2" )->FIRST
? 2->FIRST
? B->FIRST
Inkey( 0 )
@@ -98,4 +98,4 @@ FUNCTION Main()
? "Z" , dbSelectArea( "Z" ), Select()
? "AA", dbSelectArea( "AA" ), Select()
RETURN NIL
RETURN

4
harbour/tests/tstasort.prg
View File

@@ -2,7 +2,7 @@
* $Id$
*/
FUNCTION main()
PROCEDURE Main()
LOCAL oError := ErrorNew()
@@ -25,7 +25,7 @@ FUNCTION main()
? "Asort.c......:", aDump( ASort( t := AClone( c ) ) )
? "Asort.c.block:", aDump( ASort( t := AClone( c ), , , {| x, y | xToStr( x ) < xToStr( y ) } ) )
RETURN nil
RETURN
FUNCTION aDump( a )

12
harbour/tests/tstblock.prg
View File

@@ -9,14 +9,14 @@ PROCEDURE Main()
MEMVAR Var1, Var2, Var3, Macro
PRIVATE Var1, Var2, Var3, Macro
M -> Var1 := "Var1"
M -> Var2 := "Var2"
M -> Var3 := "Var3"
M->Var1 := "Var1"
M->Var2 := "Var2"
M->Var3 := "Var3"
CLS
FOR i := 1 TO 3
M -> Macro := "Var" + Str( i, 1 )
M->Macro := "Var" + Str( i, 1 )
bBlock[ i ] := { || &Macro }
NEXT
@@ -27,7 +27,7 @@ PROCEDURE Main()
NEXT
FOR i := 1 TO 3
M -> Macro := "Var" + Str( i, 1 )
M->Macro := "Var" + Str( i, 1 )
bBlock[ i ] := { || &Macro + "!" }
NEXT
@@ -39,7 +39,7 @@ PROCEDURE Main()
NEXT
FOR i := 1 TO 3
M -> Macro := "Var" + Str( i, 1 )
M->Macro := "Var" + Str( i, 1 )
bBlock[ i ] := { || &( Macro ) }
NEXT

2
harbour/tests/tstdbi.prg
View File

@@ -6,7 +6,7 @@
#xtranslate hb_eol() => ( Chr( 13 ) + Chr( 10 ) )
#endif
PROCEDURE main()
PROCEDURE Main()
LOCAL i
LOCAL cStr := ""

38
harbour/tests/tstmacro.prg
View File

@@ -14,41 +14,41 @@ FUNCTION Main( )
PRIVATE cVar_1, cMainPrivate := 'cVar_1', GlobalPrivate := 'BornInRunTimeVar'
&cStr_1 = 'Simple '
? M -> cVar_1
? M->cVar_1
&( 'cVar' + '_1' ) := 'Macro'
?? M -> cVar_1
?? M->cVar_1
M -> &cStr_1 = 'Aliased'
? M -> cVar_1
M->&cStr_1 = 'Aliased'
? M->cVar_1
MEMVAR -> &( 'cVar' + '_1' ) := ' Macro'
?? M -> cVar_1
MEMVAR->&( 'cVar' + '_1' ) := ' Macro'
?? M->cVar_1
cStr := 'cVar_'
&cStr.1 = 'Concatenated Macro (Numeric)'
? M -> cVar_1
? M->cVar_1
cStr := 'cVar'
&cStr._1 = 'Concatenated Macro (String)'
? M -> cVar_1
? M->cVar_1
&( aVar[1] ) := 'Array Macro'
? M -> cVar_1
? M->cVar_1
oVar := TValue():New()
oVar:cVal := 'cVar_1'
&( oVar:cVal ) := 'Class Macro'
? M -> cVar_1
? M->cVar_1
SubFun()
? '"cVar_1" = [' + M -> cVar_1 + '] AFTER SubFun() PRIVATE'
? '"cVar_1" = [' + M->cVar_1 + '] AFTER SubFun() PRIVATE'
? M -> NewPublicVar
? M->NewPublicVar
TEST_TYPE()
RETURN NIL
FUNCTION TValue
@@ -75,25 +75,25 @@ STATIC FUNCTION New()
FUNCTION SubFun()
? '"cVar_1" = [' + M -> cVar_1 + '] BEFORE SubFun() PRIVATE'
? '"cVar_1" = [' + M->cVar_1 + '] BEFORE SubFun() PRIVATE'
// Testing conflict with KEY WORDS
PRIVATE PRIVATE := 'I am a Var named PRIVATE ', &cMainPrivate, SomeVar, OtherVar := 1, &GlobalPrivate := 'I was born in Run Time'
PUBLIC PUBLIC := 'NewPublicVar'
PUBLIC &PUBLIC
? M -> NewPublicVar
? M->NewPublicVar
M -> NewPublicVar := 'Still Alive because I am PUBLIC'
M->NewPublicVar := 'Still Alive because I am PUBLIC'
? M -> PRIVATE + PRIVATE
? PRIVATE + M -> PRIVATE
? M->PRIVATE + PRIVATE
? PRIVATE + M->PRIVATE
? BornInRunTimeVar
&cMainPrivate := 'In SubFun()'
? '"cVar_1" = [' + M -> cVar_1 + '] in SubFun() PRIVATE'
? '"cVar_1" = [' + M->cVar_1 + '] in SubFun() PRIVATE'
RETURN NIL

300
harbour/tests/varparam.prg
View File

@@ -1,12 +1,15 @@
//
// $Id$
//
/*
* $Id$
*/
/* TEST FOR USING VARIABLE NUMBER OF PARAMETERS */
MEMVAR iLoop
PROCEDURE MAIN(p1, p2)
LOCAL l1:=11,l2:=22,l3:=33,l4:=44,l5:=55,l6:=66
PRIVATE iLoop
PROCEDURE Main( p1, p2 )
LOCAL l1 := 11, l2 := 22, l3 := 33, l4 := 44, l5 := 55, l6 := 66
PRIVATE iLoop
? 'passed 0: '; TEST_0_0( )
? 'passed 1: '; TEST_0_0( 1 )
@@ -125,201 +128,210 @@ PRIVATE iLoop
PROCEDURE TEST_0_0v( ... )
?? PROCNAME(0), ' received: ', PCOUNT()
FOR m->iLoop:=1 TO PCOUNT()
? m->iLoop, "=", HB_PVALUE( m->iLoop )
?? ProcName( 0 ), ' received: ', PCount()
FOR m->iLoop := 1 TO PCount()
? m->iLoop, "=", hb_PValue( m->iLoop )
NEXT
inkey(0)
RETURN
Inkey( 0 )
RETURN
PROCEDURE TEST_0_0( )
?? PROCNAME(0), ' received: ', PCOUNT()
FOR m->iLoop:=1 TO PCOUNT()
? m->iLoop, "=", HB_PVALUE( m->iLoop )
?? ProcName( 0 ), ' received: ', PCount()
FOR m->iLoop := 1 TO PCount()
? m->iLoop, "=", hb_PValue( m->iLoop )
NEXT
inkey(0)
RETURN
Inkey( 0 )
RETURN
PROCEDURE TEST_1_0v( ... )
LOCAL i:='i'
?? PROCNAME(0), ' received: ', PCOUNT()
? 'i=',i
FOR i:=1 TO PCOUNT()
? i, "=", HB_PVALUE( i )
LOCAL i := 'i'
?? ProcName( 0 ), ' received: ', PCount()
? 'i=', i
FOR i := 1 TO PCount()
? i, "=", hb_PValue( i )
NEXT
inkey(0)
RETURN
Inkey( 0 )
RETURN
PROCEDURE TEST_1_0( )
LOCAL i:='i'
?? PROCNAME(0), ' received: ', PCOUNT()
? 'i=',i
FOR i:=1 TO PCOUNT()
? i, "=", HB_PVALUE( i )
NEXT
inkey(0)
LOCAL i := 'i'
RETURN
PROCEDURE TEST_1_3v( a,b,c, ... )
LOCAL i:='i'
?? PROCNAME(0), ' received: ', PCOUNT()
? 'i=',i
? 'a=',a
? 'b=',b
? 'c=',c
FOR i:=1 TO PCOUNT()
? i, "=", HB_PVALUE( i )
?? ProcName( 0 ), ' received: ', PCount()
? 'i=', i
FOR i := 1 TO PCount()
? i, "=", hb_PValue( i )
NEXT
FOR EACH i IN HB_APARAMS()
Inkey( 0 )
RETURN
PROCEDURE TEST_1_3v( a, b, c, ... )
LOCAL i := 'i'
?? ProcName( 0 ), ' received: ', PCount()
? 'i=', i
? 'a=', a
? 'b=', b
? 'c=', c
FOR i := 1 TO PCount()
? i, "=", hb_PValue( i )
NEXT
FOR EACH i IN hb_AParams()
? i:__enumindex, "-", i
NEXT
inkey(0)
RETURN
PROCEDURE TEST_1_3( a,b,c )
LOCAL i:='i'
?? PROCNAME(0), ' received: ', PCOUNT()
? 'i=',i
? 'a=',a
? 'b=',b
? 'c=',c
FOR i:=1 TO PCOUNT()
? i, "=", HB_PVALUE( i )
NEXT
FOR EACH i IN HB_APARAMS()
Inkey( 0 )
RETURN
PROCEDURE TEST_1_3( a, b, c )
LOCAL i := 'i'
?? ProcName( 0 ), ' received: ', PCount()
? 'i=', i
? 'a=', a
? 'b=', b
? 'c=', c
FOR i := 1 TO PCount()
? i, "=", hb_PValue( i )
NEXT
FOR EACH i IN hb_AParams()
? i:__enumindex, "-", i
NEXT
inkey(0)
NEXT
RETURN
Inkey( 0 )
RETURN
PROCEDURE TEST_1_1( a )
LOCAL i:='i'
?? PROCNAME(0), ' received: ', PCOUNT()
? 'i=',i
? 'a=',a
FOR i:=1 TO PCOUNT()
? i, "=", HB_PVALUE( i )
LOCAL i := 'i'
?? ProcName( 0 ), ' received: ', PCount()
? 'i=', i
? 'a=', a
FOR i := 1 TO PCount()
? i, "=", hb_PValue( i )
NEXT
inkey(0)
RETURN
Inkey( 0 )
RETURN
PROCEDURE TEST_1_1v( a, ... )
LOCAL i:='i'
?? PROCNAME(0), ' received: ', PCOUNT()
? 'i=',i
? 'a=',a
FOR i:=1 TO PCOUNT()
? i, "=", HB_PVALUE( i )
LOCAL i := 'i'
?? ProcName( 0 ), ' received: ', PCount()
? 'i=', i
? 'a=', a
FOR i := 1 TO PCount()
? i, "=", hb_PValue( i )
NEXT
inkey(0)
RETURN
Inkey( 0 )
PROCEDURE TEST_3_3v( a,b,c, ... )
LOCAL x:='x', y:='y', z:='z'
RETURN
?? PROCNAME(0), ' received: ', PCOUNT()
? 'x=',x
? 'y=',y
? 'z=',z
? 'a=',a
? 'b=',b
? 'c=',c
FOR m->iLoop:=1 TO PCOUNT()
? m->iLoop, "=", HB_PVALUE( m->iLoop )
NEXT
test_ref( @a, @b, @c, @x, @y, @z )
inkey(0)
PROCEDURE TEST_3_3v( a, b, c, ... )
RETURN
LOCAL x := 'x', y := 'y', z := 'z'
PROCEDURE TEST_3_3( a,b,c )
LOCAL x:='x', y:='y', z:='z'
?? PROCNAME(0), ' received: ', PCOUNT()
? 'x=',x
? 'y=',y
? 'z=',z
? 'a=',a
? 'b=',b
? 'c=',c
FOR m->iLoop:=1 TO PCOUNT()
? m->iLoop, "=", HB_PVALUE( m->iLoop )
?? ProcName( 0 ), ' received: ', PCount()
? 'x=', x
? 'y=', y
? 'z=', z
? 'a=', a
? 'b=', b
? 'c=', c
FOR m->iLoop := 1 TO PCount()
? m->iLoop, "=", hb_PValue( m->iLoop )
NEXT
test_ref( @a, @b, @c, @x, @y, @z )
inkey(0)
RETURN
Inkey( 0 )
RETURN
PROCEDURE TEST_3_3( a, b, c )
LOCAL x := 'x', y := 'y', z := 'z'
?? ProcName( 0 ), ' received: ', PCount()
? 'x=', x
? 'y=', y
? 'z=', z
? 'a=', a
? 'b=', b
? 'c=', c
FOR m->iLoop := 1 TO PCount()
? m->iLoop, "=", hb_PValue( m->iLoop )
NEXT
test_ref( @a, @b, @c, @x, @y, @z )
Inkey( 0 )
RETURN
PROCEDURE TEST_3_0( )
LOCAL x:='x', y:='y', z:='z'
?? PROCNAME(0), ' received: ', PCOUNT()
? 'x=',x
? 'y=',y
? 'z=',z
FOR m->iLoop:=1 TO PCOUNT()
? m->iLoop, "=", HB_PVALUE( m->iLoop )
LOCAL x := 'x', y := 'y', z := 'z'
?? ProcName( 0 ), ' received: ', PCount()
? 'x=', x
? 'y=', y
? 'z=', z
FOR m->iLoop := 1 TO PCount()
? m->iLoop, "=", hb_PValue( m->iLoop )
NEXT
inkey(0)
RETURN
Inkey( 0 )
RETURN
PROCEDURE TEST_3_0v( ... )
LOCAL x:='x', y:='y', z:='z'
?? PROCNAME(0), ' received: ', PCOUNT()
? 'x=',x
? 'y=',y
? 'z=',z
FOR m->iLoop:=1 TO PCOUNT()
? m->iLoop, "=", HB_PVALUE( m->iLoop )
LOCAL x := 'x', y := 'y', z := 'z'
?? ProcName( 0 ), ' received: ', PCount()
? 'x=', x
? 'y=', y
? 'z=', z
FOR m->iLoop := 1 TO PCount()
? m->iLoop, "=", hb_PValue( m->iLoop )
NEXT
inkey(0)
RETURN
Inkey( 0 )
RETURN
PROCEDURE TEST_REF( a, ... )
LOCAL b
LOCAL b
? '@@@'
? PROCNAME(0), ' received: ', PCOUNT()
? ProcName( 0 ), ' received: ', PCount()
? 'a= ', a
? 'b= ', b
FOR EACH b IN HB_APARAMS(0)
FOR EACH b IN hb_AParams( 0 )
? b:__enumindex, "-", b
NEXT
NEXT
RETURN
RETURN

2
harbour/tests/wvt_fs.prg
View File

@@ -5,7 +5,7 @@
#include "hbgtinfo.ch"
#include "inkey.ch"
PROCEDURE MAIN()
PROCEDURE Main()
LOCAL cGt
cGt := HB_GtVersion( 0 )