From af1e261b5b90292e1a1e84ef862b28f8d189f821 Mon Sep 17 00:00:00 2001 From: Przemyslaw Czerpak Date: Thu, 9 Oct 2008 18:51:31 +0000 Subject: [PATCH] 2008-10-09 20:51 UTC+0200 Przemyslaw Czerpak (druzus/at/priv.onet.pl) * harbour/common.mak * harbour/source/rtl/Makefile + added thfuncx.prg * harbour/source/rtl/thfuncx.prg + added ThreadObject() function * harbour/source/rtl/tthreadx.prg + added xBase++ compatible TThread class. Special thanks to Pritpal Bedi for class skeleton with info about xbase++. Now only basic functionality is supported though it was enough to compile and execute examples Pritpal sent. I'm leaving rest for xBase++ users. BTW The examples suggest that in xbase++ DispOutAt() does not change cursor position. It's not Clipper compatible so I cannot make it in Harbour though I can add new function which will work in such way. --- harbour/ChangeLog | 19 ++++ harbour/common.mak | 1 + harbour/source/rtl/Makefile | 1 + harbour/source/rtl/thfuncx.prg | 12 ++- harbour/source/rtl/tthreadx.prg | 161 +++++++++++++++++++++++++++++++- 5 files changed, 190 insertions(+), 4 deletions(-) diff --git a/harbour/ChangeLog b/harbour/ChangeLog index 9f4d8db911..76c51a7734 100644 --- a/harbour/ChangeLog +++ b/harbour/ChangeLog @@ -8,6 +8,25 @@ 2008-12-31 13:59 UTC+0100 Foo Bar (foo.bar foobar.org) */ +2008-10-09 20:51 UTC+0200 Przemyslaw Czerpak (druzus/at/priv.onet.pl) + * harbour/common.mak + * harbour/source/rtl/Makefile + + added thfuncx.prg + + * harbour/source/rtl/thfuncx.prg + + added ThreadObject() function + + * harbour/source/rtl/tthreadx.prg + + added xBase++ compatible TThread class. + Special thanks to Pritpal Bedi for class skeleton with info about + xbase++. + Now only basic functionality is supported though it was enough to + compile and execute examples Pritpal sent. I'm leaving rest for + xBase++ users. + BTW The examples suggest that in xbase++ DispOutAt() does not change + cursor position. It's not Clipper compatible so I cannot make it + in Harbour though I can add new function which will work in such way. + 2008-10-09 10:48 UTC-0800 Pritpal Bedi (pritpal@vouchcac.com) ! harbour/bin/bld.bat + _C_MT= if not HB_MT==MT diff --git a/harbour/common.mak b/harbour/common.mak index dba05eaff1..fe33355313 100644 --- a/harbour/common.mak +++ b/harbour/common.mak @@ -646,6 +646,7 @@ RTL_LIB_OBJS = \ $(OBJ_DIR)\tget$(OBJEXT) \ $(OBJ_DIR)\tgetint$(OBJEXT) \ $(OBJ_DIR)\tgetlist$(OBJEXT) \ + $(OBJ_DIR)\thfuncx$(OBJEXT) \ $(OBJ_DIR)\tlabel$(OBJEXT) \ $(OBJ_DIR)\tmenuitm$(OBJEXT) \ $(OBJ_DIR)\tmenusys$(OBJEXT) \ diff --git a/harbour/source/rtl/Makefile b/harbour/source/rtl/Makefile index 43e45ab56c..5cbdbf5b8f 100644 --- a/harbour/source/rtl/Makefile +++ b/harbour/source/rtl/Makefile @@ -207,6 +207,7 @@ PRG_SOURCES=\ tget.prg \ tgetint.prg \ tgetlist.prg \ + thfuncx.prg \ tlabel.prg \ tmenuitm.prg \ tmenusys.prg \ diff --git a/harbour/source/rtl/thfuncx.prg b/harbour/source/rtl/thfuncx.prg index 6bd3d23748..0ffe00ec16 100644 --- a/harbour/source/rtl/thfuncx.prg +++ b/harbour/source/rtl/thfuncx.prg @@ -58,6 +58,14 @@ FUNCTION ThreadID() RETURN hb_threadId() +FUNCTION ThreadObject( oThread ) + THREAD STATIC s_oThread + IF PCount() > 0 + s_oThread := oThread + ENDIF + RETURN s_oThread + + FUNCTION ThreadWait( aThreads, nTimeOut ) LOCAL xResult, nPos, apThIDs, th @@ -70,7 +78,7 @@ FUNCTION ThreadWait( aThreads, nTimeOut ) ENDIF NEXT - nPos := hb_threadWait( apThIDs, iif( ISNUMBER( nTimeOut ), nTimeOut / 1000, ) ) + nPos := hb_threadWait( apThIDs, iif( ISNUMBER( nTimeOut ), nTimeOut / 100, ) ) IF nPos != 0 xResult := aThreads[ nPos ] ENDIF @@ -90,7 +98,7 @@ FUNCTION ThreadWaitAll( aThreads, nTimeOut ) ENDIF NEXT - RETURN hb_threadWait( apThIDs, iif( ISNUMBER( nTimeOut ), nTimeOut / 1000, ), ; + RETURN hb_threadWait( apThIDs, iif( ISNUMBER( nTimeOut ), nTimeOut / 100, ), ; .T. ) == Len( apThIDs ) /* TODO: ThreadInfo() */ diff --git a/harbour/source/rtl/tthreadx.prg b/harbour/source/rtl/tthreadx.prg index 64a1d1060d..fd136ff69a 100644 --- a/harbour/source/rtl/tthreadx.prg +++ b/harbour/source/rtl/tthreadx.prg @@ -8,6 +8,9 @@ * * Copyright 2008 Przemyslaw Czerpak * www - http://www.harbour-project.org + * special thanks for Pritpal Bedi for class skeleton with info about + * xbase++ and to other contributors which I hope will finish and fix + * this code * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -55,12 +58,20 @@ #ifdef HB_COMPAT_XPP +/* I do not know xBase++ values */ +#define QUIT_NORESTART 1 +#define QUIT_RESTART 2 + + +/* + * SIGNAL class + */ CREATE CLASS TSignal FUNCTION Signal VAR cargo AS USUAL EXPORTED VAR mutex AS USUAL PROTECTED - EXPORTED: +EXPORTED: METHOD new() METHOD wait( nTimeOut ) @@ -68,8 +79,9 @@ CREATE CLASS TSignal FUNCTION Signal ENDCLASS -METHOD new() CLASS TSIGNAL +METHOD new( ... ) CLASS TSIGNAL ::mutex := hb_mutexCreate() + ::Init( ... ) RETURN Self METHOD wait( nTimeOut ) CLASS TSIGNAL @@ -84,4 +96,149 @@ METHOD signal() CLASS TSIGNAL hb_mutexNotify( ::mutex ) RETURN Self + +/* + * THREAD class + */ + +CREATE CLASS TThread FUNCTION Thread + +EXPORTED: + VAR cargo AS USUAL SYNC + VAR active AS LOGICAL READONLY INIT .f. + VAR deltaTime AS NUMERIC READONLY INIT 0 + VAR interval AS USUAL READONLY INIT NIL + VAR priority AS NUMERIC READONLY INIT 0 + VAR startCount AS NUMERIC READONLY INIT 0 + VAR startTime AS USUAL READONLY INIT NIL + VAR atEnd AS USUAL INIT NIL SYNC + VAR atStart AS USUAL INIT NIL SYNC + VAR result AS USUAL INIT NIL SYNC + +PROTECTED: + VAR maxStackSize AS USUAL INIT 50000 + +HIDDEN: + VAR pThreadID AS USUAL INIT NIL SYNC + + +EXPORTED: + METHOD new( nMaxStackSize ) + +PROTECTED: + /* METHOD atEnd() */ + /* METHOD atStart() */ + METHOD execute() + +EXPORTED: + METHOD quit( xResult, nRestart ) SYNC + METHOD setInterval( nHSeconds ) + METHOD setPriority( nPriority ) + METHOD setStartTime( nSeconds ) + METHOD start() SYNC + METHOD synchronize( nTimeOut ) + METHOD threadSelf() + METHOD threadID() + + METHOD thread INLINE ::TThread() + +ENDCLASS + +METHOD new( nMaxStackSize ) CLASS TTHREAD + ::maxStackSize := nMaxStackSize + ::Init() + RETURN Self + +METHOD execute() CLASS TTHREAD + HB_SYMBOL_UNUSED( Self ) + RETURN NIL + +METHOD quit( xResult, nRestart ) CLASS TTHREAD + IF hb_threadSelf() == ::pThreadID + IF ISNUMBER( nRestart ) + IF nRestart == QUIT_NORESTART + ::interval := NIL + ELSEIF nRestart == QUIT_RESTART + IF ISNUMBER( ::interval ) + /* TODO: do not interrupt by QUIT but restart execution */ + ENDIF + ENDIF + ENDIF + IF PCOUNT() > 0 + ::result := xResult + ENDIF + QUIT + ENDIF + RETURN NIL + +METHOD setInterval( nHSeconds ) CLASS TTHREAD + IF ISNUMBER( nHSeconds ) + ::interval := nHSeconds + ENDIF + RETURN .F. + +METHOD setPriority( nPriority ) CLASS TTHREAD + /* TODO: add thread priority setting */ + IF ISNUMBER( nPriority ) + ::priority := nPriority + ENDIF + RETURN .F. + +METHOD setStartTime( nSeconds ) CLASS TTHREAD + /* TODO: add such functionality, probably by special thread */ + IF ISNUMBER( nSeconds ) + ::startTime := nSeconds + ELSEIF nSeconds == NIL + ::startTime := NIL + ENDIF + RETURN .F. + +METHOD start( xAction, ... ) CLASS TTHREAD + /* TODO: thread stack size set by user ::maxStackSize */ + IF ::active + RETURN .F. + ELSEIF xAction == NIL + ::active := .T. + ::pThreadID := hb_threadStart( { |...| + ::startTime := Seconds() + ThreadObject( Self ) + ::result := ::execute( ... ) + RETURN NIL + }, ... ) + ELSEIF !Empty( xAction ) .AND. ValType( xAction ) $ "CBP" + ::active := .T. + ::pThreadID := hb_threadStart( { |...| + ::startTime := Seconds() + ThreadObject( Self ) + IF ::atStart != NIL + EVAL( ::atStart, ... ) + ENDIF + ::result := DO( xAction, ... ) + IF ::atEnd != NIL + EVAL( ::atEnd, ... ) + ENDIF + ::startTime := NIL + RETURN NIL + }, ... ) + ELSE + RETURN .F. + ENDIF + RETURN .T. + +METHOD synchronize( nTimeOut ) CLASS TTHREAD + LOCAL pThreadID := ::pThreadID + + IF hb_threadSelf() != pThreadID + RETURN hb_threadWait( pThreadID, ; + iif( ISNUMBER( nTimeOut ), nTimeOut / 100, ) ) + ENDIF + RETURN .F. + +METHOD threadSelf() CLASS TTHREAD + RETURN ::pThreadID + +METHOD threadID() CLASS TTHREAD + LOCAL pThreadID := ::pThreadID + RETURN IIF( pThreadID == NIL, 0, hb_threadID( pThreadID ) ) + #endif