diff --git a/harbour/ChangeLog b/harbour/ChangeLog index fe558f0b2c..0c12f61f59 100644 --- a/harbour/ChangeLog +++ b/harbour/ChangeLog @@ -8,6 +8,32 @@ 2009-12-31 13:59 UTC+0100 Foo Bar (foo.bar foobar.org) */ +2009-03-19 12:27 UTC+0100 Viktor Szakats (harbour.01 syenar hu) + * contrib/xhb/Makefile + + contrib/xhb/hbserv.h + + contrib/xhb/hbserv.ch + + contrib/xhb/trpccli.prg + + contrib/xhb/hbrpc.ch + + contrib/xhb/ttable.prg + + contrib/xhb/trpc.prg + + contrib/xhb/ttable.ch + + contrib/xhb/hbserv.c + + Added few components from xhb. They compile without warnings, + but I didn't try any of them. + + * contrib/hbqt/hbqt_qabstractbutton.cpp + * contrib/hbqt/hbqt_qdialog.cpp + * contrib/hbqt/hbqt.h + * contrib/hbqt/Makefile + + Added QT_VERSION(), QT_VERSION_STR() + + Added QT version protection. + ! Fixed to use forward slashes in #include filenames. + * Changed Linux include dir autodetection. + * Changed autodetection to look for qglobal.h. + + * contrib/rddads/tests/testmg.prg + - Removed unnecessary lines. + 2009-03-19 09:10 UTC+0100 Viktor Szakats (harbour.01 syenar hu) * bin/postinst.bat - Removed generation of odbc32.lib for BCC. diff --git a/harbour/contrib/hbqt/Makefile b/harbour/contrib/hbqt/Makefile index e85830d72f..6c5e65ca3a 100644 --- a/harbour/contrib/hbqt/Makefile +++ b/harbour/contrib/hbqt/Makefile @@ -11,17 +11,18 @@ ifneq ($(HB_ARCHITECTURE),os2) ifeq ($(HB_INC_QT),) ifeq ($(HB_XBUILD),) -HB_INC_QT = /usr/include /usr/local/Trolltech/Qt-4.5.0/include /Developer/qt/include +HB_INC_QT = /usr/include/qt4 /Developer/qt/include endif endif -HB_INC_QT_OK += $(foreach d, $(HB_INC_QT), $(if $(wildcard $(d)/Qt/qatomic.h),$(d),)) +HB_INC_QT_OK += $(foreach d, $(HB_INC_QT), $(if $(wildcard $(d)/Qt/qglobal.h),$(d),)) ifneq ($(strip $(HB_INC_QT_OK)),) HB_USER_CFLAGS += $(foreach d, $(HB_INC_QT_OK), -I$(d)) CPP_SOURCES=\ + hbqt_base.cpp \ hbqt_qdialog.cpp \ hbqt_qabstractbutton.cpp \ diff --git a/harbour/contrib/hbqt/hbqt.h b/harbour/contrib/hbqt/hbqt.h index fe6ba2ed2c..895d1f65a2 100644 --- a/harbour/contrib/hbqt/hbqt.h +++ b/harbour/contrib/hbqt/hbqt.h @@ -53,7 +53,11 @@ #ifndef __HBQT_H #define __HBQT_H -#include +#include + +#if QT_VERSION >= 0x040500 + +#include #define hbqt_par_QWidget( n ) ( ( QWidget* ) hb_parptr( n ) ) #define hbqt_par_QDialog( n ) ( ( QDialog* ) hb_parptr( n ) ) @@ -61,4 +65,6 @@ #define hbqt_par_QString( n ) ( ( QString ) hb_parc( n ) ) #define hbqt_par_WindowFlags( n ) ( ( Qt::WindowFlags ) hb_parni( n ) ) +#endif + #endif /* __HBQT_H */ diff --git a/harbour/contrib/hbqt/hbqt_qabstractbutton.cpp b/harbour/contrib/hbqt/hbqt_qabstractbutton.cpp index 9b1780dba6..af595758de 100644 --- a/harbour/contrib/hbqt/hbqt_qabstractbutton.cpp +++ b/harbour/contrib/hbqt/hbqt_qabstractbutton.cpp @@ -54,7 +54,9 @@ #include "hbqt.h" -#include +#if QT_VERSION >= 0x040500 + +#include /* bool autoExclusive () const @@ -228,3 +230,5 @@ HB_FUNC( QT_QABSTRACTBUTTON_TOGGLE ) } /*----------------------------------------------------------------------*/ + +#endif diff --git a/harbour/contrib/hbqt/hbqt_qdialog.cpp b/harbour/contrib/hbqt/hbqt_qdialog.cpp index f0dab5bb22..d63b2650d1 100644 --- a/harbour/contrib/hbqt/hbqt_qdialog.cpp +++ b/harbour/contrib/hbqt/hbqt_qdialog.cpp @@ -54,6 +54,8 @@ #include "hbqt.h" +#if QT_VERSION >= 0x040500 + /* QDialog ( QWidget * parent = 0, Qt::WindowFlags f = 0 ) */ @@ -143,3 +145,5 @@ HB_FUNC( QT_QDIALOG_SETRESULT ) { hbqt_par_QDialog( 1 )->setResult( hb_parni( 2 ) ); } + +#endif diff --git a/harbour/contrib/rddads/tests/testmg.prg b/harbour/contrib/rddads/tests/testmg.prg index 6eedb66135..cb27c62290 100644 --- a/harbour/contrib/rddads/tests/testmg.prg +++ b/harbour/contrib/rddads/tests/testmg.prg @@ -55,17 +55,15 @@ #include "set.ch" #include "ads.ch" +REQUEST ADS + function Main() local i - REQUEST ADS - rddRegister( "ADS", 1 ) rddsetdefault( "ADS" ) SET SERVER LOCAL // REMOTE - AdsSetFileType(ADS_CDX) - // use test // make this available to get some stats on open tables below ? "Advantage Database Server Management Functions in Harbour" diff --git a/harbour/contrib/xhb/Makefile b/harbour/contrib/xhb/Makefile index 1e5b6eb3c1..e9d180d54b 100644 --- a/harbour/contrib/xhb/Makefile +++ b/harbour/contrib/xhb/Makefile @@ -15,6 +15,7 @@ C_SOURCES=\ hbcomprs.c \ hbcrypt.c \ hboutdbg.c \ + hbserv.c \ hbsyslog.c \ hbxml.c \ xhbarr.c \ @@ -40,6 +41,9 @@ PRG_SOURCES=\ hbstruct.prg \ regexrpl.prg \ sprintf.prg \ + trpc.prg \ + trpccli.prg \ + ttable.prg \ txml.prg \ xhbcomp.prg \ xhbmt.prg \ diff --git a/harbour/contrib/xhb/hbrpc.ch b/harbour/contrib/xhb/hbrpc.ch new file mode 100644 index 0000000000..f7df2f80c0 --- /dev/null +++ b/harbour/contrib/xhb/hbrpc.ch @@ -0,0 +1,77 @@ +/* + * $Id$ + */ + +/* + * xHarbour Project source code: + * Remote Procedure Call code + * Standard definitions + * + * Copyright 2003 Giancarlo Niccolai + * www - http://www.xharbour.org + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/). + * + * As a special exception, the Harbour Project gives permission for + * additional uses of the text contained in its release of Harbour. + * + * The exception is that, if you link the Harbour libraries with other + * files to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the Harbour library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the Harbour + * Project under the name Harbour. If you copy code from other + * Harbour Project or Free Software Foundation releases into a copy of + * Harbour, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for Harbour, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. + * + */ + +#ifndef RPC_CH +#define RPC_CH + +#define RPC_LOOP_NONE 0 +#define RPC_LOOP_SUMMARY 1 +#define RPC_LOOP_ALLDATA 2 +#define RPC_LOOP_CONFIRMATION 3 + +#define RPC_STATUS_ERROR -1 +#define RPC_STATUS_NONE 0 +#define RPC_STATUS_CONNECTING 1 +#define RPC_STATUS_CONNECTED 2 +#define RPC_STATUS_LOGGED 3 +#define RPC_STATUS_WAITING 4 + +#define RPCS_STATUS_BUSY -2 +#define RPCS_STATUS_ERROR -1 +#define RPCS_STATUS_NONE 0 +#define RPCS_STATUS_CHALLENGE 1 +#define RPCS_STATUS_LOGGED 2 +#define RPCS_STATUS_RUNNING 3 +#define RPCS_STATUS_CLOSED 10 + +#endif diff --git a/harbour/contrib/xhb/hbserv.c b/harbour/contrib/xhb/hbserv.c new file mode 100644 index 0000000000..58cc334016 --- /dev/null +++ b/harbour/contrib/xhb/hbserv.c @@ -0,0 +1,1086 @@ +/* +* $Id$ +*/ + +/* +* xHarbour Project source code: +* The Service/Daemon support +* (Includes also signal/low level error management) +* +* Copyright 2003 Giancarlo Niccolai [gian@niccolai.ws] +* www - http://www.xharbour.org +* +* this program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General public License as published by +* the Free Software Foundation; either version 2, or (at your option) +* any later version. +* +* this program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS for A PARTICULAR PURPOSE. See the +* GNU General public License for more details. +* +* You should have received a copy of the GNU General public License +* along with this software; see the file COPYING. if not, write to +* the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/). +* +* As a special exception, xHarbour license gives permission for +* additional uses of the text contained in its release of xHarbour. +* +* The exception is that, if you link the xHarbour libraries with other +* files to produce an executable, this does not by itself cause the +* resulting executable to be covered by the GNU General public License. +* Your use of that executable is in no way restricted on account of +* linking the xHarbour library code into it. +* +* this exception does not however invalidate any other reasons why +* the executable file might be covered by the GNU General public License. +* +* this exception applies only to the code released with this xHarbour +* explicit exception. if you add/copy code from other sources, +* as the General public License permits, the above exception does +* not apply to the code that you add in this way. To avoid misleading +* anyone as to the status of such modified files, you must delete +* this exception notice from them. +* +* If you write modifications of your own for xHarbour, it is your choice +* whether to permit this exception to apply to your modifications. +* if you do not wish that, delete this exception notice. +* +*/ + +#define HB_OS_WIN_USED + +#include "hbapi.h" +#include "hbapiitm.h" +#include "hbapierr.h" +#include "hbapifs.h" +#include "hbvm.h" +#include "hbstack.h" +#include "hbserv.h" +#include "hbthread.h" + +#include + +#if !defined( HB_OS_DOS ) && !defined( HB_OS_DARWIN_5 ) /* DOS and Darwin < 6.x can't compile this module */ + +#if defined( HB_OS_UNIX ) || defined (HB_OS_OS2_GCC) +#include +#include +#include +#endif + +/* TODO: + we'll use hb_fsPopen for popening once we put it multiplatform. For now: */ +#ifdef HB_OS_WIN + #define popen _popen + #define pclose _pclose +#endif + +#ifdef __LCC__ +#define EXCEPTION_ILLEGAL_INSTRUCTION STATUS_ILLEGAL_INSTRUCTION +#endif + +extern PHB_FUNC pHVMFuncService; + +/************************************************** +* Global definition, valid for all systems +***************************************************/ + +static void s_serviceSetHBSig( void ); +static void s_serviceSetDflSig( void ); +static void s_signalHandlersInit( void ); + +static PHB_ITEM sp_hooks = NULL; +static BOOL bSignalEnabled = TRUE; +static int sb_isService = 0; + +/* There is a service mutex in multithreading */ +static HB_CRITICAL_NEW( s_ServiceMutex ); + +/* This structure holds a translation to transform a certain OS level signal +into abstract HB_SIGNAL; os specific implementation must provide the +s_sigTable containing all the available translations */ + +typedef struct +{ + UINT sig; + UINT subsig; + UINT translated; +} S_TUPLE; + +static int s_translateSignal( UINT sig, UINT subsig ); + +/***************************************************************************** +* Unix specific signal handling implementation +* +* This section has unix specific code to manage the +* signals, both from kernel or from users. +*****************************************************************************/ + +#if defined(HB_OS_UNIX) || defined (HB_OS_OS2_GCC) + +/* TODO: Register the old signal action to allow graceful fallback + static struct sigaction sa_oldAction[ SIGUSR2 + 1 ]; */ + +/* Implementation of the signal translation table */ +static S_TUPLE s_sigTable[] = +{ + { SIGHUP, 0, HB_SIGNAL_REFRESH }, + { SIGINT, 0, HB_SIGNAL_INTERRUPT }, + { SIGQUIT, 0, HB_SIGNAL_QUIT }, + { SIGILL, 0, HB_SIGNAL_FAULT }, + { SIGABRT, 0, HB_SIGNAL_QUIT }, + { SIGFPE, 0, HB_SIGNAL_MATHERR }, + { SIGSEGV, 0, HB_SIGNAL_FAULT }, + { SIGTERM, 0, HB_SIGNAL_QUIT }, + { SIGUSR1, 0, HB_SIGNAL_USER1 }, + { SIGUSR2, 0, HB_SIGNAL_USER2 }, + { 0, 0, 0 } +}; + +#if defined( HB_OS_OS2_GCC ) || defined( __WATCOMC__ ) +static void s_signalHandler( int sig ) +#else +static void s_signalHandler( int sig, siginfo_t * info, void * v ) +#endif +{ + UINT uiMask; + UINT uiSig; + PHB_ITEM pFunction, pExecArray, pRet; + ULONG ulPos; + int iRet; + + #if !( defined( HB_OS_OS2_GCC ) || defined( __WATCOMC__ ) ) + HB_SYMBOL_UNUSED( v ); + #endif + + /* let's find the right signal handler. */ + hb_threadEnterCriticalSection( &s_ServiceMutex ); + + /* avoid working if PRG signal handling has been disabled */ + if( ! bSignalEnabled ) + { + hb_threadLeaveCriticalSection( &s_ServiceMutex ); + return; + } + + bSignalEnabled = FALSE; + ulPos = hb_arrayLen( sp_hooks ); + /* subsig not necessary */ + uiSig = ( UINT ) s_translateSignal( ( UINT ) sig, 0 ); + + while( ulPos > 0 ) + { + pFunction = hb_arrayGetItemPtr( sp_hooks, ulPos ); + uiMask = ( UINT ) hb_arrayGetNI( pFunction, 1 ); + if( uiMask & uiSig ) + { + /* we don't unlock the mutex now, even if it is + a little dangerous. But we are in a signal hander... + for now just 2 parameters */ + pExecArray = hb_itemArrayNew( 3 ); + hb_arraySet( pExecArray, 1, hb_arrayGetItemPtr( pFunction, 2 ) ); + hb_arraySetNI( pExecArray, 2, uiSig ); + + /* the third parameter is an array: */ + + pRet = hb_arrayGetItemPtr( pExecArray, 3); + #if defined( HB_OS_OS2_GCC ) || defined( __WATCOMC__ ) + hb_arrayNew( pRet, 1 ); + #elif defined( HB_OS_BSD ) + hb_arrayNew( pRet, info ? 6 : 1 ); + #else + hb_arrayNew( pRet, 6 ); + #endif + hb_arraySetNI( pRet, HB_SERVICE_OSSIGNAL, sig ); + #if !( defined( HB_OS_OS2_GCC ) || defined( __WATCOMC__ ) ) + #if defined( HB_OS_BSD ) + if( info ) + #endif + { + hb_arraySetNI( pRet, HB_SERVICE_OSSUBSIG, info->si_code ); + hb_arraySetNI( pRet, HB_SERVICE_OSERROR, info->si_errno ); + hb_arraySetPtr( pRet, HB_SERVICE_ADDRESS, ( void * ) info->si_addr ); + hb_arraySetNI( pRet, HB_SERVICE_PROCESS, info->si_pid ); + hb_arraySetNI( pRet, HB_SERVICE_UID, info->si_uid ); + } + #endif + + pRet = hb_itemDo( pExecArray, 0 ); + iRet = hb_itemGetNI( pRet ); + hb_itemRelease( pRet ); + hb_itemRelease( pExecArray ); + + switch( iRet ) + { + case HB_SERVICE_HANDLED: + bSignalEnabled = TRUE; + hb_threadLeaveCriticalSection( &s_ServiceMutex ); + return; + + case HB_SERVICE_QUIT: + bSignalEnabled = FALSE; + hb_threadLeaveCriticalSection( &s_ServiceMutex ); + /* TODO: A service cleanup routine */ + hb_vmRequestQuit(); + /* Allow signals to go through pthreads */ + s_serviceSetDflSig(); + /* NOTICE: should be pthread_exit(0), but a bug in linuxthread prevents it: + calling pthread exit from a signal handler will cause infinite wait for + restart signal. + This solution is rude, while the other would allow clean VM termination... + but it works. + */ + exit( 0 ); + } + } + ulPos--; + } + + bSignalEnabled = TRUE; + /*s_serviceSetHBSig();*/ + + /* TODO + if( uiSig != HB_SIGNAL_UNKNOWN ) + { + if( sa_oldAction[ sig ].sa_flags & SA_SIGINFO ) + sa_oldAction[ sig ].sa_sigaction( sig, info, v ); + else + sa_oldAction[ sig ].sa_handler( sig ); + } + */ +} + +/* 2003 - + to fix as soon as thread support is ready on OS/2 +*/ +#if defined(HB_THREAD_SUPPORT) && ! defined(HB_OS_OS2) +void * s_signalListener( void * my_stack ) +{ + static BOOL bFirst = TRUE; + sigset_t passall; + HB_STACK * pStack = ( HB_STACK * ) my_stack; +#if defined( HB_OS_BSD ) + int sig; +#else + siginfo_t sinfo; +#endif + +#ifdef HB_THREAD_TLS_KEYWORD + hb_thread_stack = my_stack; +#else + pthread_setspecific( hb_pkCurrentStack, my_stack ); +#endif + + pStack->th_id = HB_CURRENT_THREAD(); + hb_threadLinkStack( pStack ); + HB_STACK_LOCK; + + /* and now accepts all signals */ + sigemptyset( &passall ); + + /* and wait for all signals */ + sigaddset( &passall, SIGHUP ); + sigaddset( &passall, SIGQUIT ); + sigaddset( &passall, SIGILL ); + sigaddset( &passall, SIGABRT ); + sigaddset( &passall, SIGFPE ); + sigaddset( &passall, SIGSEGV ); + sigaddset( &passall, SIGTERM ); + sigaddset( &passall, SIGUSR1 ); + sigaddset( &passall, SIGUSR2 ); + sigaddset( &passall, SIGHUP ); + + pthread_cleanup_push( hb_threadTerminator, my_stack ); + pthread_setcanceltype( PTHREAD_CANCEL_DEFERRED, NULL ); + pthread_setcancelstate( PTHREAD_CANCEL_ENABLE, NULL ); + + for( ;; ) + { + /* allow safe cancelation */ + HB_STACK_UNLOCK; + + /* reset signal handling; this is done here (so I don't + mangle with pthread_ calls, and I don't hold mutexes), + and just once (doing it twice would be useless). */ + if( bFirst ) + { + pthread_sigmask( SIG_SETMASK, &passall, NULL ); + bFirst = FALSE; + } + + /* This is also a cancelation point. When the main thread + is done, it will kill all the threads having a stack + including this one. + ATM we don't care very much about signal handling during + termination: no handler is set for them, so the DFL + action is taken (and that should be fine). */ +#if defined( HB_OS_BSD ) + sigwait( &passall, &sig ); +#else + sigwaitinfo( &passall, &sinfo ); +#endif + + /* lock stack before passing the ball to VM. */ + HB_STACK_LOCK; +#if defined( HB_OS_BSD ) + s_signalHandler( sig, NULL, NULL ); +#else + s_signalHandler( sinfo.si_signo, &sinfo, NULL ); +#endif + } + + pthread_cleanup_pop( 1 ); + return 0; +} +#endif +#endif + +/***************************************************************************** +* Windows specific exception filter system. +* +* Windows will only catch exceptions; It is necessary to rely on the +* HB_SERVICELOOP to receive user generated messages. +*****************************************************************************/ + +#ifdef HB_OS_WIN +static void s_serviceSetHBSig( void ); + +/* message filter hook for user generated signals */ +static HHOOK s_hMsgHook = NULL; + +/* old error mode */ +static UINT s_uiErrorMode = 0; + +/* ------------------------------- + implementation of the signal translation table + Under windows, 0 is a system exception, while 1 is a user message +*/ +static S_TUPLE s_sigTable[] = { + + /* memory/processor fault exception */ + { 0, EXCEPTION_ACCESS_VIOLATION, HB_SIGNAL_FAULT }, + { 0, EXCEPTION_ILLEGAL_INSTRUCTION, HB_SIGNAL_FAULT }, + { 0, EXCEPTION_IN_PAGE_ERROR, HB_SIGNAL_FAULT }, + { 0, EXCEPTION_STACK_OVERFLOW, HB_SIGNAL_FAULT }, + { 0, EXCEPTION_PRIV_INSTRUCTION, HB_SIGNAL_FAULT }, + { 0, EXCEPTION_ARRAY_BOUNDS_EXCEEDED, HB_SIGNAL_FAULT }, + { 0, EXCEPTION_DATATYPE_MISALIGNMENT, HB_SIGNAL_FAULT }, + + /* Math exceptions */ + { 0, EXCEPTION_FLT_DENORMAL_OPERAND, HB_SIGNAL_MATHERR }, + { 0, EXCEPTION_FLT_INVALID_OPERATION, HB_SIGNAL_MATHERR }, + { 0, EXCEPTION_FLT_INEXACT_RESULT, HB_SIGNAL_MATHERR }, + { 0, EXCEPTION_FLT_DIVIDE_BY_ZERO, HB_SIGNAL_MATHERR }, + { 0, EXCEPTION_FLT_OVERFLOW, HB_SIGNAL_MATHERR }, + { 0, EXCEPTION_FLT_STACK_CHECK, HB_SIGNAL_MATHERR }, + { 0, EXCEPTION_FLT_UNDERFLOW, HB_SIGNAL_MATHERR }, + { 0, EXCEPTION_INT_DIVIDE_BY_ZERO, HB_SIGNAL_MATHERR }, + { 0, EXCEPTION_INT_OVERFLOW, HB_SIGNAL_MATHERR }, + + /* User requests */ + { 1, WM_USER , HB_SIGNAL_USER1 }, + { 1, WM_USER + 1, HB_SIGNAL_USER2 }, + { 1, WM_USER + 2, HB_SIGNAL_REFRESH }, + { 1, WM_USER + 3, HB_SIGNAL_INTERRUPT }, + { 1, WM_QUIT, HB_SIGNAL_QUIT }, + + /* Console handler */ + { 2, CTRL_C_EVENT, HB_SIGNAL_INTERRUPT }, + { 2, CTRL_BREAK_EVENT, HB_SIGNAL_INTERRUPT }, + { 2, CTRL_CLOSE_EVENT, HB_SIGNAL_QUIT }, + { 2, CTRL_LOGOFF_EVENT, HB_SIGNAL_QUIT }, + { 2, CTRL_SHUTDOWN_EVENT, HB_SIGNAL_QUIT }, + + {0 , 0, 0} +}; + +/* ------------------------------- + Manager of signals for windows +*/ +static LONG s_signalHandler( int type, int sig, PEXCEPTION_RECORD exc ) +{ + PHB_ITEM pFunction, pExecArray, pRet; + ULONG ulPos; + UINT uiSig, uiMask; + int iRet; + + /* let's find the right signal handler. */ + hb_threadEnterCriticalSection( &s_ServiceMutex ); + + /* avoid working if PRG signal handling has been disabled */ + if( ! bSignalEnabled ) + { + hb_threadLeaveCriticalSection( &s_ServiceMutex ); + return EXCEPTION_EXECUTE_HANDLER; + } + + bSignalEnabled = FALSE; + ulPos = hb_arrayLen( sp_hooks ); + /* subsig not necessary */ + uiSig = ( UINT ) s_translateSignal( ( UINT ) type, ( UINT ) sig ); + + while( ulPos > 0 ) + { + pFunction = hb_arrayGetItemPtr( sp_hooks, ulPos ); + uiMask = ( UINT ) hb_arrayGetNI( pFunction, 1 ); + if( ( uiMask & uiSig ) == uiSig ) + { + /* we don't unlock the mutex now, even if it is + a little dangerous. But we are in a signal hander... + for now just 2 parameters */ + pExecArray = hb_itemArrayNew( 3 ); + hb_arraySetForward( pExecArray, 1, hb_arrayGetItemPtr( pFunction, 2 ) ); + hb_arraySetNI( pExecArray, 2, uiSig ); + + /* the third parameter is an array: + * 1: low-level signal + * 2: low-level subsignal + * 3: low-level system error + * 4: address that rised the signal + * 5: process id of the signal riser + * 6: UID of the riser + */ + + pRet = hb_arrayGetItemPtr( pExecArray, 3); + hb_arrayNew( pRet, 6 ); + + hb_arraySetNI( pRet, HB_SERVICE_OSSIGNAL, type ); + hb_arraySetNI( pRet, HB_SERVICE_OSSUBSIG, sig ); + /* could be meaningless, but does not matter here */ + hb_arraySetNI( pRet, HB_SERVICE_OSERROR, GetLastError() ); + + if(type == 0 ) /* exception */ + { + hb_arraySetPtr( pRet, HB_SERVICE_ADDRESS, ( void * ) exc->ExceptionAddress ); + } + else + { + hb_arraySetPtr( pRet, HB_SERVICE_ADDRESS, NULL ); + } + /* TODO: */ + hb_arraySetNI( pRet, HB_SERVICE_PROCESS, GetCurrentThreadId() ); + /* TODO: */ + hb_arraySetNI( pRet, HB_SERVICE_UID, 0 ); + + pRet = hb_itemDo( pExecArray, 0 ); + iRet = hb_itemGetNI( pRet ); + hb_itemRelease( pRet ); + hb_itemRelease( pExecArray ); + + switch( iRet ) + { + case HB_SERVICE_HANDLED: + bSignalEnabled = TRUE; + hb_threadLeaveCriticalSection( &s_ServiceMutex ); + return EXCEPTION_CONTINUE_EXECUTION; + + case HB_SERVICE_QUIT: + bSignalEnabled = FALSE; + hb_threadLeaveCriticalSection( &s_ServiceMutex ); + hb_vmRequestQuit(); + #ifndef HB_THREAD_SUPPORT + hb_vmQuit(); + exit(0); + #else + hb_threadCancelInternal(); + #endif + + } + } + ulPos--; + } + + bSignalEnabled = TRUE; + return EXCEPTION_EXECUTE_HANDLER; +} + + +static LRESULT CALLBACK s_exceptionFilter( PEXCEPTION_POINTERS exInfo ) +{ + return s_signalHandler( 0, exInfo->ExceptionRecord->ExceptionCode, exInfo->ExceptionRecord ); +} + +static LRESULT CALLBACK s_MsgFilterFunc( int nCode, WPARAM wParam, LPARAM lParam ) +{ + PMSG msg; + + if( nCode < 0 ) + return CallNextHookEx( s_hMsgHook, nCode, wParam, lParam ); + + msg = ( PMSG ) lParam; + + switch( msg->message ) + { + case WM_USER: + case WM_USER+1: + case WM_USER+2: + case WM_USER+3: + case WM_QUIT: + /* we'll ignore the request here. + the application must still receive the message */ + s_signalHandler( 1, msg->message, NULL ); + } + + /* return next hook anyway */ + return CallNextHookEx( s_hMsgHook, nCode, wParam, lParam ); +} + +#ifdef HB_THREAD_SUPPORT +extern DWORD hb_dwCurrentStack; +#endif + +BOOL WINAPI s_ConsoleHandlerRoutine( DWORD dwCtrlType ) +{ +#ifdef HB_THREAD_SUPPORT + HB_STACK * pStack = NULL; + + /* we need a new stack: this is NOT an hb thread. */ + + if( TlsGetValue( hb_dwCurrentStack ) == 0 ) + { + pStack = hb_threadCreateStack( GetCurrentThreadId() ); + pStack->th_h = GetCurrentThread(); + TlsSetValue( hb_dwCurrentStack, ( void * ) pStack ); + } +#endif + + s_signalHandler( 2, dwCtrlType, NULL ); + +#ifdef HB_THREAD_SUPPORT + if( pStack ) + hb_threadDestroyStack( pStack ); +#endif + /* We have handled it */ + return TRUE; +} + +#endif + +/***************************************************************************** +* Filter/handlers setup/shutdown +* This utility functions are meant to abstract the process of declare and +* remove the signal handlers, and do it in a mutltiplatform fashon. Use this +* to implement new platform signal/exception handlers. +*****************************************************************************/ + +/*----------------------------------------------------- + Set the signal handlers to our program interceptors. +*/ + +static void s_serviceSetHBSig( void ) +{ + +#if defined( HB_OS_UNIX ) || defined(HB_OS_OS2_GCC) + struct sigaction act; + + #if defined(HB_THREAD_SUPPORT) && ! defined(HB_OS_OS2) + sigset_t blockall; + /* set signal mask */ + sigemptyset( &blockall ); + sigaddset( &blockall, SIGHUP ); + sigaddset( &blockall, SIGQUIT ); + sigaddset( &blockall, SIGILL ); + sigaddset( &blockall, SIGABRT ); + sigaddset( &blockall, SIGFPE ); + sigaddset( &blockall, SIGSEGV ); + sigaddset( &blockall, SIGTERM ); + sigaddset( &blockall, SIGUSR1 ); + sigaddset( &blockall, SIGUSR2 ); + sigaddset( &blockall, SIGHUP ); + + pthread_sigmask( SIG_SETMASK, &blockall, NULL ); + #endif + + /* to avoid problems with differ sigaction structures and uninitialized + fields */ + memset( &act, 0, sizeof( struct sigaction ) ); + + #if defined( HB_OS_OS2_GCC ) || defined( __WATCOMC__ ) + act.sa_handler = s_signalHandler; + #else + /* using more descriptive sa_action instead of sa_handler */ + act.sa_handler = NULL; /* if act.sa.. is a union, we just clean this */ + act.sa_sigaction = s_signalHandler; /* this is what matters */ + /* block al signals, we don't want to be interrupted. */ + /*sigfillset( &act.sa_mask );*/ + #endif + + + #ifdef HB_OS_OS2_GCC + act.sa_flags = SA_NOCLDSTOP; + #else + act.sa_flags = SA_NOCLDSTOP | SA_SIGINFO; + #endif + + sigaction( SIGHUP, &act, NULL ); + sigaction( SIGQUIT, &act, NULL ); + sigaction( SIGILL, &act, NULL ); + sigaction( SIGABRT, &act, NULL ); + sigaction( SIGFPE, &act, NULL ); + sigaction( SIGSEGV, &act, NULL ); + sigaction( SIGTERM, &act, NULL ); + sigaction( SIGUSR1, &act, NULL ); + sigaction( SIGUSR2, &act, NULL ); + + /* IGNORE pipe */ + signal( SIGPIPE, SIG_IGN ); +#endif + +#ifdef HB_OS_WIN + /* disable all os-level error boxes */ + s_uiErrorMode = SetErrorMode( + SEM_FAILCRITICALERRORS | SEM_NOALIGNMENTFAULTEXCEPT | SEM_NOGPFAULTERRORBOX | + SEM_NOOPENFILEERRORBOX ); + + SetUnhandledExceptionFilter( s_exceptionFilter ); + s_hMsgHook = SetWindowsHookEx( WH_GETMESSAGE, (HOOKPROC) s_MsgFilterFunc, NULL, GetCurrentThreadId() ); + SetConsoleCtrlHandler( s_ConsoleHandlerRoutine, TRUE ); + +#endif +} +/* --------------------------------------------------- + Reset the signal handlers to the default OS value +*/ + + +static void s_serviceSetDflSig( void ) +{ +#ifdef HB_OS_UNIX + signal( SIGHUP, SIG_DFL ); + signal( SIGQUIT, SIG_DFL ); + signal( SIGILL, SIG_DFL ); + signal( SIGABRT, SIG_DFL ); + signal( SIGFPE, SIG_DFL ); + signal( SIGSEGV, SIG_DFL ); + signal( SIGTERM, SIG_DFL ); + signal( SIGUSR1, SIG_DFL ); + signal( SIGUSR2, SIG_DFL ); + signal( SIGPIPE, SIG_DFL ); +#endif + +#ifdef HB_OS_WIN + SetUnhandledExceptionFilter( NULL ); + if( s_hMsgHook != NULL ) + { + UnhookWindowsHookEx( s_hMsgHook ); + s_hMsgHook = NULL; + } + SetErrorMode( s_uiErrorMode ); + SetConsoleCtrlHandler( s_ConsoleHandlerRoutine, FALSE ); +#endif +} + + +/* --------------------------------------------------- + This translates a signal into abstract HB_SIGNAL + from os specific representation +*/ + +static int s_translateSignal( UINT sig, UINT subsig ) +{ + int i = 0; + while( s_sigTable[i].sig != 0 || s_sigTable[i].subsig !=0 || s_sigTable[i].translated != 0 ) + { + if( s_sigTable[i].sig == sig && + ( s_sigTable[i].subsig == subsig || s_sigTable[i].subsig == 0 ) ) + { + return s_sigTable[i].translated; + } + i++; + } + return HB_SIGNAL_UNKNOWN; +} + +/** +* Initializes signal handler system +*/ + +static void s_signalHandlersInit() +{ + #if defined( HB_THREAD_SUPPORT ) && ( defined( HB_OS_UNIX ) || defined( HB_OS_UNIX_COMPATIBLE ) ) + pthread_t res; + HB_STACK * pStack; + + s_serviceSetHBSig(); + + pStack = hb_threadCreateStack( 0 ); + pthread_create( &res, NULL, s_signalListener, pStack ); + #else + s_serviceSetHBSig(); + #endif + + sp_hooks = hb_itemNew( NULL ); + hb_arrayNew( sp_hooks, 0 ); +} + +/***************************************************************************** +* HB_*Service routines +* This is the core of the service system. +*****************************************************************************/ + +/** +* Starts the service system. +* Initializes the needed variables. +* On unix: if the parameter is .T., puts the server in daemonic mode, detaching +* the main thread from the console and terminating it. +*/ + +HB_FUNC( HB_STARTSERVICE ) +{ + #ifdef HB_THREAD_SUPPORT + int iCount = hb_threadCountStacks(); + if( iCount > 2 || ( sp_hooks == NULL && iCount > 1 ) ) + { + /*TODO: Right error code here*/ + hb_errRT_BASE_SubstR( EG_ARG, 3012, "Service must be started before starting threads", NULL, 0); + return; + } + #endif + + #ifdef HB_OS_UNIX + { + int pid; + + /* Iconic? */ + if( hb_parl( 1 ) ) + { + pid = fork(); + + if( pid != 0 ) + { + hb_vmRequestQuit(); + return; + } + #ifdef HB_THREAD_SUPPORT + #ifdef HB_THREAD_TLS_KEYWORD + hb_thread_stack = &hb_stackMT; + #else + pthread_setspecific( hb_pkCurrentStack, (void *) &hb_stackMT ); + #endif + #endif + } + } + #endif + + /* let's begin */ + sb_isService = TRUE; + pHVMFuncService = ( PHB_FUNC ) hb_isService; + + /* in windows, we just detach from console */ + #ifdef HB_OS_WIN + if( hb_parl( 1 ) ) + { + FreeConsole(); + } + #endif + + /* Initialize only if the service has not yet been initialized */ + if( sp_hooks == NULL ) + { + s_signalHandlersInit(); + } +} + +/** +* Returns true if the current program is a service, that is if HB_StartService() has +* Been called. C version useful for internal api +*/ + +BOOL hb_isService() +{ + return sb_isService; +} + +/** +* Clean up when system exits +* Called from hb_vmQuit() +*/ + +void hb_serviceExit() +{ + if( sp_hooks != NULL ) + { + /* reset default signal handling */ + s_serviceSetDflSig(); + hb_itemRelease( sp_hooks ); + } +} + + +/** +* Returns true if the current program is a service, that is if HB_StartService() has +* Been called. +*/ +HB_FUNC( HB_ISSERVICE ) +{ + hb_retl( sb_isService ); +} + +/** +* This is -at least- an helper functions that implements the main loop for +* the service/daemon system. +* The minimal thing to do is a hb_gcCollectAll(), because, generally, servers +* are not interactive, so they tend to have garbage to collect. +* Under windows, it peeks the pending messages and send the relevant ones +* (quit, user+1 and user+2) to our handling functions. +*/ + +HB_FUNC( HB_SERVICELOOP ) +{ +#ifdef HB_OS_WIN + MSG msg; + /* This is just here to trigger our internal hook routine, if the + final application does not any message handling. + */ + if( ! PeekMessage( &msg, NULL, WM_QUIT, WM_QUIT, PM_REMOVE ) ) + { + PeekMessage( &msg, NULL, WM_USER, WM_USER+3, PM_REMOVE ); + } +#endif + + hb_gcCollectAll( FALSE ); +} + +HB_FUNC( HB_PUSHSIGNALHANDLER ) +{ + int iMask = hb_parni( 1 ); + PHB_ITEM pFunc = hb_param( 2, HB_IT_ANY ), pHandEntry; + + if( pFunc == NULL || iMask == 0 || + (! HB_IS_POINTER( pFunc ) && ! HB_IS_STRING( pFunc ) && ! HB_IS_BLOCK( pFunc ) ) + ) + { + hb_errRT_BASE_SubstR( EG_ARG, 3012, "Wrong parameter count/type", NULL, + 2, hb_param( 1, HB_IT_ANY ), hb_param( 2, HB_IT_ANY )); + return; + } + + pHandEntry = hb_itemArrayNew( 2 ); + hb_arraySetNI( pHandEntry, 1, iMask ); + hb_arraySet( pHandEntry, 2, pFunc ); + + /* if the hook is not initialized, initialize it */ + if( sp_hooks == NULL ) + { + s_signalHandlersInit(); + } + + hb_threadEnterCriticalSection( &s_ServiceMutex ); + + hb_arrayAddForward( sp_hooks, pHandEntry ); + + hb_threadLeaveCriticalSection( &s_ServiceMutex ); + + hb_itemRelease( pHandEntry ); +} + + +HB_FUNC( HB_POPSIGNALHANDLER ) +{ + int nLen; + + if( sp_hooks != NULL ) + { + hb_threadEnterCriticalSection( &s_ServiceMutex ); + + nLen = hb_arrayLen( sp_hooks ); + if( nLen > 0 ) + { + hb_arrayDel( sp_hooks, nLen ); + hb_arrayDel( sp_hooks, nLen - 1 ); + hb_arraySize( sp_hooks, nLen - 2 ); + hb_retl( TRUE ); + if( hb_arrayLen( sp_hooks ) == 0 ) + { + hb_itemRelease( sp_hooks ); + sp_hooks = NULL; /* So it can be reinitilized */ + } + } + else + { + hb_retl( FALSE ); + } + hb_threadLeaveCriticalSection( &s_ServiceMutex ); + } + else + { + hb_retl( FALSE ); + } +} + +/** +* Return a character description of the low level signal that has been +* issued to signal handling routines. This is system dependant. +* TODO: Make it international through the xHarbour standard message system. +*/ +HB_FUNC( HB_SIGNALDESC ) +{ + int iSig = hb_parni( 1 ); + int iSubSig = hb_parni( 2 ); + + /* UNIX MESSGES */ + #if defined (HB_OS_UNIX) || defined(HB_OS_OS2_GCC) + + switch( iSig ) + { + case SIGSEGV: switch( iSubSig ) + { + #if ! defined(HB_OS_BSD) && ! defined(HB_OS_OS2_GCC) && ! defined( __WATCOMC__ ) + case SEGV_MAPERR: hb_retc( "Segmentation fault: address not mapped to object"); return; + case SEGV_ACCERR: hb_retc( "Segmentation fault: invalid permissions for mapped object"); return; + #endif + default: hb_retc("Segmentation fault"); return; + } + + case SIGILL: switch( iSubSig ) + { + #if ! defined(HB_OS_BSD) && ! defined(HB_OS_OS2_GCC) && ! defined( __WATCOMC__ ) + case ILL_ILLOPC: hb_retc( "Illegal operation: illegal opcode"); return; + case ILL_ILLOPN: hb_retc( "Illegal operation: illegal operand"); return; + case ILL_ILLADR: hb_retc( "Illegal operation: illegal addressing mode"); return; + case ILL_ILLTRP: hb_retc( "Illegal operation: illegal trap"); return; + case ILL_PRVOPC: hb_retc( "Illegal operation: privileged opcode"); return; + case ILL_PRVREG: hb_retc( "Illegal operation: privileged register"); return; + case ILL_COPROC: hb_retc( "Illegal operation: coprocessor error"); return; + case ILL_BADSTK: hb_retc( "Illegal operation: internal stack error"); return; + #endif + default: hb_retc( "Illegal operation" ); return; + } + + case SIGFPE: switch( iSubSig ) + { + #if ! defined(HB_OS_OS2_GCC) && ! defined( __WATCOMC__ ) + #if ! defined( HB_OS_DARWIN ) + case FPE_INTDIV: hb_retc( "Floating point: integer divide by zero"); return; + case FPE_INTOVF: hb_retc( "Floating point: integer overflow"); return; + #endif + case FPE_FLTDIV: hb_retc( "Floating point: floating point divide by zero"); return; + case FPE_FLTOVF: hb_retc( "Floating point: floating point overflow"); return; + case FPE_FLTUND: hb_retc( "Floating point: floating point underflow"); return; + case FPE_FLTRES: hb_retc( "Floating point: floating point inexact result"); return; + case FPE_FLTINV: hb_retc( "Floating point: floating point invalid operation"); return; + #if ! defined( HB_OS_DARWIN ) + case FPE_FLTSUB: hb_retc( "Floating point: subscript out of range"); return; + #endif + #endif + default: hb_retc( "Floating point" ); return; + } + + case SIGQUIT: + hb_retc( "Quit" ); + return; + + case SIGHUP: + hb_retc( "Update" ); + return; + + case SIGINT: + hb_retc( "Interrupt" ); + return; + + case SIGPIPE: + hb_retc( "Broken pipe" ); + return; + + case SIGTERM: + hb_retc( "Terminate process" ); + return; + + case SIGABRT: + hb_retc( "Abort" ); + + case SIGUSR1: + hb_retc( "User defined" ); + return; + + case SIGUSR2: + hb_retc( "User defined (secondary)" ); + return; + } + #endif + + #ifdef HB_OS_WIN + if( iSig == 0 ) /* exception */ + { + switch( iSubSig ) + { + case EXCEPTION_ACCESS_VIOLATION: + hb_retc("Memory read/write access violation"); return; + + case EXCEPTION_ARRAY_BOUNDS_EXCEEDED: + hb_retc("Array out of bounds" ); return; + + case EXCEPTION_DATATYPE_MISALIGNMENT: + hb_retc("Data misaligned" ); return; + + case EXCEPTION_FLT_DENORMAL_OPERAND: + hb_retc("Denormal operand in Floating-point operation"); return; + + case EXCEPTION_FLT_DIVIDE_BY_ZERO: + hb_retc("Floating-point division by zero"); return; + + case EXCEPTION_FLT_INEXACT_RESULT: + hb_retc("Inexact floating-point operation result"); return; + + case EXCEPTION_FLT_INVALID_OPERATION: + hb_retc("Invalid floating-point operation"); return; + + case EXCEPTION_FLT_OVERFLOW: + hb_retc("Floating-point numeric overflow"); return; + + case EXCEPTION_FLT_STACK_CHECK: + hb_retc("Floating-point out of stack"); return; + + case EXCEPTION_FLT_UNDERFLOW: + hb_retc("Floating-point numeric underflow"); return; + + case EXCEPTION_ILLEGAL_INSTRUCTION: + hb_retc("Illegal instruction"); return; + + case EXCEPTION_IN_PAGE_ERROR: + hb_retc("Paging error"); return; + + case EXCEPTION_INT_DIVIDE_BY_ZERO: + hb_retc("Integer division by zero"); return; + + case EXCEPTION_INT_OVERFLOW: + hb_retc("Integer numeric overflow"); return; + + case EXCEPTION_PRIV_INSTRUCTION: + hb_retc("Illegal instruction for current machine mode"); return; + + case EXCEPTION_STACK_OVERFLOW: + hb_retc("Stack overflow"); return; + } + } + + #endif + + hb_retc("Unrecognized signal"); +} + + +/***************************************************************************** +* Debug help: generates a fault or a math error to see if signal catching +* is working +**************************************/ + +HB_FUNC( HB_SERVICEGENERATEFAULT ) +{ + int *pGPF = NULL; + + *pGPF = 0; + /* if it doesn't cause GPF (on some platforms it's possible) try this */ + *(--pGPF) = 0; +} + +HB_FUNC( HB_SERVICEGENERATEFPE ) +{ + static double a = 100.0, b = 0.0; + a = a / b; +} + +#endif diff --git a/harbour/contrib/xhb/hbserv.ch b/harbour/contrib/xhb/hbserv.ch new file mode 100644 index 0000000000..c170e8f780 --- /dev/null +++ b/harbour/contrib/xhb/hbserv.ch @@ -0,0 +1,90 @@ +/* +* $Id$ +*/ + +/* +* xHarbour Project source code: +* The Service/Daemon support +* (Includes also signal/low level error management) +* +* Copyright 2003 Giancarlo Niccolai [gian@niccolai.ws] +* www - http://www.xharbour.org +* +* this program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General public License as published by +* the Free Software Foundation; either version 2, or (at your option) +* any later version. +* +* this program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS for A PARTICULAR PURPOSE. See the +* GNU General public License for more details. +* +* You should have received a copy of the GNU General public License +* along with this software; see the file COPYING. if not, write to +* the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/). +* +* As a special exception, xHarbour license gives permission for +* additional uses of the text contained in its release of xHarbour. +* +* The exception is that, if you link the xHarbour libraries with other +* files to produce an executable, this does not by itself cause the +* resulting executable to be covered by the GNU General public License. +* Your use of that executable is in no way restricted on account of +* linking the xHarbour library code into it. +* +* this exception does not however invalidate any other reasons why +* the executable file might be covered by the GNU General public License. +* +* this exception applies only to the code released with this xHarbour +* explicit exception. if you add/copy code from other sources, +* as the General public License permits, the above exception does +* not apply to the code that you add in this way. To avoid misleading +* anyone as to the status of such modified files, you must delete +* this exception notice from them. +* +* If you write modifications of your own for xHarbour, it is your choice +* whether to permit this exception to apply to your modifications. +* if you do not wish that, delete this exception notice. +* +*/ + +#ifndef HB_SERVICE_CH +#define HB_SERVICE_CH + +/* Abstract signal types */ +#define HB_SIGNAL_QUIT 0x0001 +#define HB_SIGNAL_INTERRUPT 0x0002 +#define HB_SIGNAL_REFRESH 0x0004 +#define HB_SIGNAL_MATHERR 0x0010 +#define HB_SIGNAL_FAULT 0x0020 +#define HB_SIGNAL_USER1 0x0040 +#define HB_SIGNAL_USER2 0x0080 +#define HB_SIGNAL_UNKNOWN 0xf000 +#define HB_SIGNAL_ALL 0xffff + +/* Signal handler return types */ +#define HB_SERVICE_CONTINUE 1 +#define HB_SERVICE_HANDLED 2 +#define HB_SERVICE_QUIT 3 + + +/* Index in the OS dependant signal array that is passed to the + signal handler as a parameter + 1: low-level signal + 2: low-level subsignal + 3: low-level system error + 4: address that rised the signal + 5: process id of the signal riser + 6: UID of the riser +*/ + +#define HB_SERVICE_OSSIGNAL 1 +#define HB_SERVICE_OSSUBSIG 2 +#define HB_SERVICE_OSERROR 3 +#define HB_SERVICE_ADDRESS 4 +#define HB_SERVICE_PROCESS 5 +#define HB_SERVICE_UID 6 + +#endif diff --git a/harbour/contrib/xhb/hbserv.h b/harbour/contrib/xhb/hbserv.h new file mode 100644 index 0000000000..5caefc2fd0 --- /dev/null +++ b/harbour/contrib/xhb/hbserv.h @@ -0,0 +1,62 @@ +/* +* $Id$ +*/ + +/* +* xHarbour Project source code: +* The Service/Daemon support +* +* Copyright 2003 Giancarlo Niccolai [gian@niccolai.ws] +* www - http://www.xharbour.org +* +* this program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General public License as published by +* the Free Software Foundation; either version 2, or (at your option) +* any later version. +* +* this program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS for A PARTICULAR PURPOSE. See the +* GNU General public License for more details. +* +* You should have received a copy of the GNU General public License +* along with this software; see the file COPYING. if not, write to +* the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/). +* +* As a special exception, xHarbour license gives permission for +* additional uses of the text contained in its release of xHarbour. +* +* The exception is that, if you link the xHarbour libraries with other +* files to produce an executable, this does not by itself cause the +* resulting executable to be covered by the GNU General public License. +* Your use of that executable is in no way restricted on account of +* linking the xHarbour library code into it. +* +* this exception does not however invalidate any other reasons why +* the executable file might be covered by the GNU General public License. +* +* this exception applies only to the code released with this xHarbour +* explicit exception. if you add/copy code from other sources, +* as the General public License permits, the above exception does +* not apply to the code that you add in this way. To avoid misleading +* anyone as to the status of such modified files, you must delete +* this exception notice from them. +* +* If you write modifications of your own for xHarbour, it is your choice +* whether to permit this exception to apply to your modifications. +* if you do not wish that, delete this exception notice. +* +*/ + +#ifndef HB_SERVICE_H +#define HB_SERVICE_H + +#ifndef HB_SERVICE_CH +#include "hbserv.ch" +#endif +HB_EXTERN_BEGIN +HB_EXPORT BOOL hb_isService( void ); +HB_EXPORT void hb_serviceExit( void ); +HB_EXTERN_END +#endif diff --git a/harbour/contrib/xhb/trpc.prg b/harbour/contrib/xhb/trpc.prg new file mode 100644 index 0000000000..753adcd510 --- /dev/null +++ b/harbour/contrib/xhb/trpc.prg @@ -0,0 +1,1628 @@ +/* + * $Id$ + */ + +/* + * xHarbour Project source code: + * Remote Procedure Call code + * xHarbour part + * + * Copyright 2003 Giancarlo Niccolai + * www - http://www.xharbour.org + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/). + * + * As a special exception, the Harbour Project gives permission for + * additional uses of the text contained in its release of Harbour. + * + * The exception is that, if you link the Harbour libraries with other + * files to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the Harbour library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the Harbour + * Project under the name Harbour. If you copy code from other + * Harbour Project or Free Software Foundation releases into a copy of + * Harbour, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for Harbour, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. + * + */ + +/* + XHB Remote procedure call protocol + + NOTES: + All packets begin with the string "XHBR??" where ?? are 2 readable characters + containing the packet type. In the protocol, a field in "" means a serialized + string. A field in {} means a serialized array. A field in '' means a literal + set of bytes (characters). + + Serialized strings: 4 chars lenght in network order, and then the string. + Function serial numbers: "AAAAMMDD.C", where c is a developer defined character. + + UDP requests: + 00 - Server scan + + "Server Name" ( valid regex or nothing ) + + 01 - Function scan + + "Function Name" (valid regex) + + "Minimum Serial" (00000000.0 for all) + + UDP replies: + 10 - Server available + + "server name" + 11 - Function available + +"server name" + +"function description" as returned by tRPCFunction::Describe() + + 12 - Too many functions in function request + + + + TCP requests: + + As UDP + + + 20 - Function call + - raw data length + "Function name" + { Param1, ... Param N } + + 21 - Compressed function call + - Original data length + - compressed data length + * follows compressed data containing serialized name + params + + 22 - Loop Function Call + - Raw data length + "A" or "C" or "E": send all results/ send compressed result/ + send confirmation at end + Numeric BEGIN + Numeric END + Numeric STEP + "Function name" + { Param1, ... Param N } + Note: the parameter called $1 is the loop indicator + + 23 - Loop Function Call / Compressed + - Original data length + - compressed data length + "A" or "C" or "E": send all results/ send compressed result/ + send confirmation at end + * follows compressed data containing: + Numeric BEGIN + Numeric END + Numeric STEP + "Function name" + { Param1, ... Param N } + Note: the parameter called $1 is the loop indicator + + 24 - Foreach function call + - raw data length + "A" or "C" or "E": send all results/ send compressed result/ + send confirmation at end + "Function name" + { Param1, ... Param N } + +Array containing the elements + Note: the parameter called $1 is substitued with the foreach + + 25 - Foreach function call / Compressed + - Original data length + - compressed data length + "A" or "C" or "E": send all results/ send compressed result/ + send confirmation at end + * follows compressed data containing: + "Function name" + { Param1, ... Param N } + +Array containing the elements + Note: the parameter called $1 is substitued with the foreach + + 29 - Cancelation request + + TCP REPLIES: + + 30 - Function result + + - raw data len + + Serialized result + + 31 - Compressed result + + - Original data length + + -compressed data len + + Compressed data containing serialized result + + 33 - Progress + + Serialized progress number (0 to 100 float) + + 34 - Progress with raw data + + Serialized progress number (0 to 100 float) (10 chars) + + - raw data len + + Uncompressed progress data + + 35 - Progress with compressed data + + Serialized progress number (0 to 100 float) (10 chars) + + - Original data length + + - compressed data lenght + + Compressed progress data + + + 40 - Function call error + 00 - Function not present + 01 - Not enough level + 02 - wrong parameters + + 10 - Internal function error + (function specific error code)+ cErrorDesc:45 + 11 - busy, retry later + + 20 - Protocol error + + 90 - LOGIN + + USERID:PASSWORD + 91 - LOGIN STATUS + 'OK' + 'NO' + 92 - GOODBYE + + 93 - Encripted login + Total length + 'USERID:ENCRYPTED( Random data + PASSWORD:pwd: + Random data)' + + 94 - Challenge + Total length + 'ENCRYPT(CHALLENGE DATA)' + + 95 - Challenge reply + - the CRC32 checksum of challenge. + + +*/ + +#include "hbclass.ch" + +#include "xhb.ch" + +#include "hbrpc.ch" + + +/************************************ +* RPC FUNCTION +*************************************/ + +CLASS tRPCFunction + DATA cName + DATA aParameters + DATA cReturn + DATA cSerial + DATA nAuthLevel + + DATA oExecutable + DATA oMethod + + DATA aCall + + CLASSDATA cPattern INIT HB_RegexComp( "^C:[0-9]{1,6}$|^A$|^O$|^D$|^N$|^NI$") + + METHOD New( cFname, cSerial, cFret, aParams, nAuthLevel, oExec, oMethod ) CONSTRUCTOR + METHOD SetCallable( oExecSymbol, oMethod ) + METHOD CheckTypes( aParams ) + METHOD CheckParam( cParam ) + METHOD Describe() + METHOD Run( aParams, oClient ) +ENDCLASS + + +METHOD New( cFname, cSerial, nAuthLevel, oExec, oMeth ) CLASS tRPCFunction + LOCAL cParam + LOCAL aParams, aFuncDef + + // Analyze the function definition + aFuncDef := HB_Regex( "^([a-zA-Z0-9_-]+)\(([^)]*)\) *(-->)? *(.*)$", cFname ) + IF Empty( aFuncDef ) + Alert( "Invalid function defintion" ) + ErrorLevel( 1 ) + QUIT + ENDIF + + ::cName := aFuncDef[2] + cParam := aFuncDef[3] + ::cReturn := IIF( Len( aFuncDef ) == 4, aFuncDef[4], aFuncDef[5] ) + + // analyze parameter list + IF Len( Trim( cParam ) ) > 0 + aParams := hb_ATokens( cParam, "," ) + ::aParameters := {} + FOR EACH cParam IN aParams + cParam := AllTrim( Upper(cParam) ) + ::CheckParam( cParam ) + AAdd( ::aParameters, cParam ) + NEXT + ELSE + ::aParameters := {} + ENDIF + + // Analyze function definition return + ::CheckParam( ::cReturn ) + + // Analyze function serial number + IF .not. HB_RegexMatch( "[0-9]{8}\..", cSerial ) + Alert( "Serial value not valid" ) + ErrorLevel( 1 ) + QUIT + ENDIF + + // analyze function authorization level + IF nAuthLevel < 1 + Alert( "Authorization level must be at least 1" ) + ErrorLevel( 1 ) + QUIT + ENDIF + + ::cSerial := cSerial + ::nAuthLevel := nAuthLevel + + // Set now Executable object if given + IF oExec != NIL + ::SetCallable( oExec, oMeth ) + ENDIF + +RETURN Self + + +METHOD SetCallable( oExec, oMeth ) CLASS tRPCFunction + // If the callable is an object, we need to store the method + IF ValType( oExec ) == "O" + ::aCall := Array( Len( ::aParameters ) + 3 ) + ::aCall[2] := oMeth + ELSE + ::aCall := Array( Len( ::aParameters ) + 2 ) + ENDIF + + ::aCall[1] := oExec + +RETURN .T. + +METHOD Run( aParams, oClient ) CLASS tRPCFunction + LOCAL nStart, nCount, xRet + + IF .not. ::CheckTypes( aParams ) + RETURN NIL + ENDIF + + nStart := IIF( ValType( ::aCall[1] ) == "O", 3, 2 ) + + FOR nCount := 1 TO Len( aParams ) + ::aCall[ nStart ] := aParams[ nCount ] + nStart ++ + NEXT + + ::aCall[ nStart ] := oClient + + xRet := HB_ExecFromArray( ::aCall ) +RETURN xRet + + +METHOD CheckParam( cParam ) CLASS tRPCFunction + IF .not. HB_RegexMatch( ::cPattern, cParam ) + Alert("tRPCFunction:CheckParam() wrong parameter specification: " + cParam ) + QUIT + ENDIF +RETURN .T. + + +METHOD CheckTypes( aParams ) CLASS tRPCFunction + LOCAL oElem, i := 0 + + IF ValType( aParams ) != 'A' + RETURN .F. + ENDIF + + IF Len( aParams ) != Len( ::aParameters ) + RETURN .F. + ENDIF + + FOR EACH oElem in ::aParameters + i++ + IF ValType( aParams[i] ) != oElem[1] + RETURN .F. + ENDIF + NEXT +RETURN .T. + + +METHOD Describe() CLASS tRPCFunction + LOCAL cRet := ::cName + "(" + LOCAL nCount + + IF Len( ::aParameters ) > 0 + FOR nCount := 1 TO Len( ::aParameters ) -1 + cRet += ::aParameters[nCount] + "," + NEXT + cRet += ::aParameters[ -1 ] + ENDIF + + cRet += ")-->" + ::cReturn + +RETURN cRet+"/" + ::cSerial + + +/*********************************************************** +* Connection manager class; this manages a single connection +************************************************************/ + +CLASS tRPCServeCon + /* back reference to the parent to get callback blocks */ + DATA oServer + + /* Socket, mutex and thread */ + DATA skRemote + DATA mtxBusy + DATA thSelf INIT NIL + + /* Assigned authorization level */ + DATA nAuthLevel + + /* User ID */ + DATA cUserId + + /* Allow progress ?*/ + DATA lAllowProgress + + METHOD New( oCaller, skRemote ) CONSTRUCTOR + METHOD Destroy() + + /* Managing async */ + METHOD Start() + METHOD Stop() + METHOD Run() + + /* Utilty */ + METHOD SendProgress( nProgress, aData ) + METHOD IsCanceled() INLINE ::lCanceled + + METHOD GetStatus() INLINE ::nStatus +HIDDEN: + /* Current status */ + DATA nStatus INIT RPCS_STATUS_NONE + /* Is this connection encrypted? */ + DATA bEncrypted + /* crc for challenge handshake */ + DATA nChallengeCRC + /* Temporary supposed user in challenge */ + DATA cChallengeUserid + DATA cCryptKey + + /* Function execution data */ + DATA thFunction INIT NIL + DATA lCanceled INIT .F. + + METHOD RecvAuth( lEncrypt ) + METHOD RecvChallenge() + METHOD RecvFunction( bComp, bMode ) + METHOD FuncCall( cData ) + METHOD FuncLoopCall( cData, cMode ) + METHOD FuncForeachCall( cData, cMode ) + METHOD LaunchChallenge( cUserid, cPassword ) + METHOD LaunchFunction( cFuncName, aParms, nMode, aItems ) + METHOD FunctionRunner( cFuncName, oFunc, nMode, aParams, aItems ) + METHOD SendResult( oRet ) + + METHOD Encrypt(cDataIn) + METHOD Decrypt(cDataIn) + +ENDCLASS + + +METHOD New( oParent, skIn ) CLASS tRPCServeCon + ::oServer := oParent + ::skRemote := skIn + ::mtxBusy := HB_MutexCreate() + ::bEncrypted := .F. + ::nAuthLevel := 0 + ::nChallengeCRC := -1 +RETURN Self + + +METHOD Destroy() CLASS tRPCServeCon + HB_MutexLock( ::mtxBusy ) + // Eventually wait for the function to terminate + IF ::thFunction != NIL + ::lCanceled := .T. + HB_MutexUnlock( ::mtxBusy ) + JoinThread( ::thFunction ) + HB_MutexLock( ::mtxBusy ) + ENDIF + + ::skRemote := NIL + HB_MutexUnlock( ::mtxBusy ) +RETURN .T. + + +METHOD Start() CLASS tRPCServeCon + LOCAL lRet := .F. + + HB_MutexLock( ::mtxBusy ) + IF ::thSelf == NIL + ::thSelf := StartThread( Self, "RUN" ) + lRet := .T. + ENDIF + HB_MutexUnlock( ::mtxBusy ) + +RETURN lRet + + +METHOD Stop() CLASS tRPCServeCon + LOCAL lRet := .F. + + HB_MutexLock( ::mtxBusy ) + IF IsValidThread( ::thSelf ) + KillThread( ::thSelf ) + lRet := .T. + HB_MutexUnlock( ::mtxBusy ) + JoinThread( ::thSelf ) + ::thSelf := NIL + ELSE + HB_MutexUnlock( ::mtxBusy ) + ENDIF + +RETURN lRet + + +METHOD Run() CLASS tRPCServeCon + LOCAL cCode := Space( 6 ) + LOCAL lBreak := .F. + LOCAL aData + LOCAL nSafeStatus + + DO WHILE InetErrorCode( ::skRemote ) == 0 .and. .not. lBreak + + /* Get the request code */ + InetRecvAll( ::skRemote, @cCode, 6 ) + IF InetErrorCode( ::skRemote ) != 0 + EXIT + ENDIF + + HB_MutexLock( ::mtxBusy ) + nSafeStatus := ::nStatus + HB_MutexUnlock( ::mtxBusy ) + + DO CASE + + /* Check for TCP server scan */ + CASE cCode == "XHBR00" + InetSendAll( ::skRemote, ; + "XHBR10"+ HB_Serialize( ::oServer:cServerName ) ) + + /* Read autorization request */ + CASE cCode == "XHBR90" + IF nSafeStatus == RPCS_STATUS_NONE + lBreak := .not. ::RecvAuth( .F. ) + IF .not. lBreak + nSafeStatus := RPCS_STATUS_LOGGED + ENDIF + ELSE + nSafeStatus := RPCS_STATUS_ERROR + ENDIF + + /* Read encrypted autorization request */ + CASE cCode == "XHBR93" + IF nSafeStatus == RPCS_STATUS_NONE + lBreak := .not. ::RecvAuth( .T. ) + IF .not. lBreak + nSafeStatus := RPCS_STATUS_CHALLENGE + ENDIF + ELSE + nSafeStatus := RPCS_STATUS_ERROR + ENDIF + + /* Challeng reply */ + CASE cCode == "XHBR95" + IF nSafeStatus == RPCS_STATUS_CHALLENGE + lBreak := .not. ::RecvChallenge( ) + IF .not. lBreak + nSafeStatus := RPCS_STATUS_LOGGED + ENDIF + ELSE + nSafeStatus := RPCS_STATUS_ERROR + ENDIF + + /* Close connection */ + CASE cCode == "XHBR92" + ::oServer:OnClientLogout( Self ) + lBreak := .T. + + /* Execute function */ + CASE cCode == "XHBR20" + IF nSafeStatus == RPCS_STATUS_LOGGED + aData := ::RecvFunction( .F., .F. ) + IF aData != NIL + lBreak := .not. ::FuncCall( aData[2] ) + ELSE + lBreak := .T. + ENDIF + ELSEIF nSafeStatus == RPCS_STATUS_RUNNING + nSafeStatus := RPCS_STATUS_BUSY + ELSE + nSafeStatus := RPCS_STATUS_ERROR + ENDIF + + + /* Execute function */ + CASE cCode == "XHBR21" + IF nSafeStatus == RPCS_STATUS_LOGGED + aData := ::RecvFunction( .T., .F. ) + IF aData != NIL + lBreak := .not. ::FuncCall( aData[2] ) + ELSE + lBreak := .T. + ENDIF + ELSEIF nSafeStatus == RPCS_STATUS_RUNNING + nSafeStatus := RPCS_STATUS_BUSY + ELSE + nSafeStatus := RPCS_STATUS_ERROR + ENDIF + + /* Loop function */ + CASE cCode == "XHBR22" + IF nSafeStatus == RPCS_STATUS_LOGGED + aData := ::RecvFunction( .F., .T. ) + IF aData != NIL + lBreak := .not. ::FuncLoopCall( aData[1], aData[2] ) + ELSE + lBreak := .T. + ENDIF + ELSEIF nSafeStatus == RPCS_STATUS_RUNNING + nSafeStatus := RPCS_STATUS_BUSY + ELSE + nSafeStatus := RPCS_STATUS_ERROR + ENDIF + + /* Loop function - compressed */ + CASE cCode == "XHBR23" + IF nSafeStatus == RPCS_STATUS_LOGGED + aData := ::RecvFunction( .T., .T. ) + IF aData != NIL + lBreak := .not. ::FuncLoopCall( aData[1], aData[2] ) + ELSE + lBreak := .T. + ENDIF + ELSEIF nSafeStatus == RPCS_STATUS_RUNNING + nSafeStatus := RPCS_STATUS_BUSY + ELSE + nSafeStatus := RPCS_STATUS_ERROR + ENDIF + + /* Foreach function */ + CASE cCode == "XHBR24" + IF nSafeStatus == RPCS_STATUS_LOGGED + aData := ::RecvFunction( .F., .T. ) + IF aData != NIL + lBreak := .not. ::FuncForeachCall( aData[1], aData[2] ) + ELSE + lBreak := .T. + ENDIF + ELSEIF nSafeStatus == RPCS_STATUS_RUNNING + nSafeStatus := RPCS_STATUS_BUSY + ELSE + nSafeStatus := RPCS_STATUS_ERROR + ENDIF + + /* Foreach function - compressed*/ + CASE cCode == "XHBR25" + IF nSafeStatus == RPCS_STATUS_LOGGED + aData := ::RecvFunction( .T., .T. ) + IF aData != NIL + lBreak := .not. ::FuncForeachCall( aData[1], aData[2] ) + ELSE + lBreak := .T. + ENDIF + ELSEIF nSafeStatus == RPCS_STATUS_RUNNING + nSafeStatus := RPCS_STATUS_BUSY + ELSE + nSafeStatus := RPCS_STATUS_ERROR + ENDIF + + /* Function execution cancelation request */ + CASE cCode == "XHBR29" + /* Note: even if the function is already terminated in the + meanwhile, and the -real- status is not RUNNING anymore, + there is no problem here. The cancelation request will + be reset at next function call, and the caller must ignore + any pending data before the "cancel" call */ + IF nSafeStatus != RPCS_STATUS_RUNNING + nSafeStatus := RPCS_STATUS_ERROR + ELSE + HB_MutexLock( ::mtxBusy ) + ::lCanceled = .T. + HB_MutexUnlock( ::mtxBusy ) + InetSendAll( ::skRemote, "XHBR34") + ENDIF + + OTHERWISE + lBreak := .T. + ENDCASE + + /* Analisys of the nSafeStatus code */ + DO CASE + CASE nSafeStatus == RPCS_STATUS_BUSY + InetSendAll( ::skRemote, "XHBR4011" ) + + CASE nSafeStatus == RPCS_STATUS_ERROR + InetSendAll( ::skRemote, "XHBR4020" ) + + /* Update real status only if not in error case */ + OTHERWISE + /* The running status is set (in this thread) indipendently + by the function launcher, if everything is fine */ + HB_MutexLock( ::mtxBusy ) + IF ::nStatus != RPCS_STATUS_RUNNING + ::nStatus := nSafeStatus + ENDIF + HB_MutexUnlock( ::mtxBusy ) + ENDCASE + + ENDDO + + // signaling termination of this thread + ::oServer:Terminating( Self ) + // Destroy resources just before termination + ::Destroy() +RETURN .T. + + +METHOD RecvAuth( lEncrypt ) CLASS tRPCServeCon + LOCAL cLength := Space(8), nLen, nPos + LOCAL cUserID, cPassword + LOCAL cReadIn + + IF InetRecvAll( ::skRemote, @cLength, 8 ) != 8 + RETURN .F. + ENDIF + + nLen := HB_GetLen8( cLength ) + + IF (lEncrypt .and. nLen > 128 ) .or. ( .not. lEncrypt .and. nLen > 37 ) + RETURN .F. + ENDIF + + cReadIn := Space( nLen ) + IF InetRecvAll( ::skRemote, @cReadin, nLen ) != nLen + RETURN .F. + ENDIF + + nPos := At( ":", cReadin ) + IF nPos == 0 + RETURN .F. + ENDIF + + cUserID := Substr(cReadin, 1, nPos-1 ) + cPassword := Substr( cReadin, nPos+1 ) + + IF .not. lEncrypt + ::nAuthLevel := ::oServer:Authorize( cUserid, cPassword ) + IF ::nAuthLevel == 0 + InetSendAll( ::skRemote, "XHBR91NO" ) + RETURN .F. + ENDIF + + InetSendAll( ::skRemote, "XHBR91OK" ) + IF InetErrorCode( ::skRemote ) != 0 + RETURN .F. + ENDIF + ::cUserId := cUserId + ::oServer:OnClientLogin( Self ) + RETURN .T. + ENDIF + +RETURN ::LaunchChallenge( cUserid, cPassword ) + + +METHOD LaunchChallenge( cUserid, cPassword ) CLASS tRPCServeCon + LOCAL cChallenge, nCount + + ::cCryptKey := ::oServer:AuthorizeChallenge( cUserid, cPassword ) + IF Empty( ::cCryptKey ) + RETURN .F. + ENDIF + + ::cChallengeUserid := cUserid + + /* Let's generate the sequence */ + cChallenge := Space( 255 ) + FOR nCount := 1 TO 255 + cChallenge[ nCount ] := Chr( HB_Random(0,255 ) ) + NEXT + + ::nChallengeCRC = HB_Checksum( cChallenge ) + cChallenge := HB_Crypt( cChallenge, ::cCryptKey ) + + InetSendAll( ::skRemote, "XHBR94" + HB_CreateLen8( Len( cChallenge ) ) + cChallenge ) + + IF InetErrorCode( ::skRemote ) != 0 + RETURN .F. + ENDIF + +RETURN .T. + + +METHOD RecvChallenge() CLASS tRPCServeCon + LOCAL cNumber := Space( 8 ) + + IF InetRecvAll( ::skRemote, @cNumber ) != 8 + RETURN .F. + ENDIF + + IF ::nChallengeCRC != HB_GetLen8( cNumber ) + RETURN .F. + ENDIF + + InetSendAll( ::skRemote, "XHBR91OK" ) + IF InetErrorCode( ::skRemote ) != 0 + RETURN .F. + ENDIF + + ::nAuthLevel := ::oServer:Authorize( ::cChallengeUserid ) + /* It is always possible that the user has been deleted in the meanwhile */ + IF ::nAuthLevel == 0 + RETURN .F. + ENDIF + + ::cUserId := ::cChallengeUserid + ::bEncrypted := .T. + ::oServer:OnClientLogin( Self ) + +RETURN .T. + + +METHOD RecvFunction( bComp, bMode ) CLASS tRPCServeCon + LOCAL cLength := Space(8), nLen, nComp + LOCAL cMode := " " + LOCAL cData + + /* Original lenght of data */ + IF InetRecvAll( ::skRemote, @cLength, 8 ) != 8 + RETURN NIL + ENDIF + + nLen := HB_GetLen8( cLength ) + IF nLen > 65000 + RETURN NIL + ENDIF + + /* compressed lenght */ + IF bComp + IF InetRecvAll( ::skRemote, @cLength, 8 ) != 8 + RETURN NIL + ENDIF + + nComp := HB_GetLen8( cLength ) + ELSE + nComp := nLen + ENDIF + + /* Mode */ + IF bMode + IF InetRecvAll( ::skRemote, @cMode ) != 1 + RETURN NIL + ENDIF + ENDIF + + /* Get data */ + cData := Space( nComp ) + IF InetRecvAll( ::skRemote, @cData ) != nComp + RETURN NIL + ENDIF + + /* Eventually decrypt it */ + IF ::bEncrypted + cData := ::Decrypt( cData ) + ENDIF + + /* Eventually uncompress it */ + IF bComp + cData := HB_Uncompress( nLen, cData ) + ENDIF + +RETURN { cMode, cData } + + +METHOD FuncCall( cData ) CLASS tRPCServeCon + LOCAL cSer, cFuncName, aParams + + /* Deserialize all elements */ + cSer := HB_DeserialBegin( cData ) + IF cSer == NIL + RETURN .F. + ENDIF + cFuncName := HB_DeserialNext( @cSer ) + aParams := HB_DeserialNext( @cSer ) + + IF aParams == NIL + RETURN .F. + ENDIF + + ::oServer:OnClientRequest( Self, 20, { cFuncName, aParams } ) +RETURN ::LaunchFunction( cFuncName, aParams, 0 ) + + +METHOD FuncLoopCall( cMode, cData ) CLASS tRPCServeCon + LOCAL nBegin, nEnd, nStep + LOCAL cSer + LOCAL cFuncName, aParams + + /* Deserialize all elements */ + cSer := HB_DeserialBegin( cData ) + IF Empty( cSer ) + RETURN .F. + ENDIF + nBegin := HB_DeserialNext( @cSer ) + nEnd := HB_DeserialNext( @cSer ) + nStep := HB_DeserialNext( @cSer ) + cFuncName := HB_DeserialNext( @cSer ) + aParams := HB_DeserialNext( @cSer ) + + IF aParams == NIL + RETURN .F. + ENDIF + + ::oServer:OnClientRequest( Self, 22, { cFuncName, aParams, cMode, nBegin, nEnd, nStep } ) +RETURN ::LaunchFunction( cFuncName, aParams, 1, { cMode, nBegin, nEnd, nStep } ) + + +METHOD FuncForeachCall( cMode, cData ) CLASS tRPCServeCon + LOCAL cSer + LOCAL cFuncName, aParams + LOCAL aItems + + /* Deserialize all elements */ + cSer := HB_DeserialBegin( cData ) + IF Empty( cSer ) + RETURN .F. + ENDIF + + cFuncName := HB_DeserialNext( @cSer ) + aParams := HB_DeserialNext( @cSer ) + aItems := HB_DeserialNext( @cSer ) + + IF aItems == NIL + RETURN .F. + ENDIF + + ::oServer:OnClientRequest( Self, 24, { cFuncName, aParams, aItems } ) +RETURN ::LaunchFunction( cFuncName, aParams, 2, { cMode, aItems } ) + + +METHOD LaunchFunction( cFuncName, aParams, nMode, aDesc ) CLASS tRPCServeCon + LOCAL oFunc + + //Check for function existance + oFunc := ::oServer:Find( cFuncName ) + IF Empty(oFunc) + // signal error + ::oServer:OnFunctionError( Self, cFuncName, 00 ) + InetSendAll( ::skRemote, "XHBR4000" ) + RETURN .T. + ENDIF + + // check for level + IF oFunc:nAuthLevel > ::nAuthLevel + // signal error + ::oServer:OnFunctionError( Self, cFuncName, 01 ) + InetSendAll( ::skRemote, "XHBR4001" ) + RETURN .T. + ENDIF + + //check for parameters + IF aParams == NIL .or. .not. oFunc:CheckTypes( aParams ) + // signal error + ::oServer:OnFunctionError( Self, cFuncName,02 ) + InetSendAll( ::skRemote, "XHBR4002" ) + RETURN .T. + ENDIF + + HB_MutexLock( ::mtxBusy ) + // allow progress indicator by default + ::lAllowProgress := .T. + // setting the cancel indicator as false + ::lCanceled := .F. + // Set the running status + ::nStatus := RPCS_STATUS_RUNNING + ::thFunction := StartThread( Self, "FunctionRunner", ; + cFuncName, oFunc, nMode, aParams, aDesc ) + HB_MutexUnlock( ::mtxBusy ) + +RETURN .T. + + +METHOD FunctionRunner( cFuncName, oFunc, nMode, aParams, aDesc ) CLASS tRPCServeCon + LOCAL nCount + LOCAL oRet, oElem, aRet + LOCAL aSubst, nSubstPos + + //? "TH:", ::thFunction + DO CASE + + CASE nMode == 0 // just run the function + oRet := oFunc:Run( aParams, Self ) + // Notice: SendResult checks for lCanceled before really sending + + CASE nMode == 1 // run in loop + aSubst := AClone( aParams ) + nSubstPos := AScan( aParams, {|x| ValType( x ) == "C" .and. x == "$."} ) + + SWITCH aDesc[1] + CASE 'A' // all results + FOR nCount := aDesc[ 2 ] TO aDesc[ 3 ] STEP aDesc[ 4 ] + IF nSubstPos > 0 + aSubst[ nSubstPos ] := nCount + ENDIF + oRet := oFunc:Run( aSubst, Self ) + ::SendResult( oRet, cFuncName ) + NEXT + oRet := "Done" + EXIT + + CASE 'C' // Vector of all results + aRet := {} + ::lAllowProgress = .F. + FOR nCount := aDesc[ 2 ] TO aDesc[ 3 ] STEP aDesc[ 4 ] + IF nSubstPos > 0 + aSubst[ nSubstPos ] := nCount + ENDIF + oRet := oFunc:Run( aSubst, Self ) + IF oRet == NIL + ::SendResult( NIL, cFuncName ) + EXIT + ENDIF + AAdd( aRet, oRet ) + NEXT + IF oRet != NIL + oRet := aRet + ENDIF + EXIT + + CASE 'E' // Just send confirmation at end + ::lAllowProgress = .F. + FOR nCount := aDesc[ 2 ] TO aDesc[ 3 ] STEP aDesc[ 4 ] + IF nSubstPos > 0 + aSubst[ nSubstPos ] := nCount + ENDIF + oRet := oFunc:Run( aSubst, Self ) + IF oRet == NIL + ::SendResult( NIL, cFuncName ) + EXIT + ENDIF + NEXT + IF oRet != NIL + oRet := "Done" + ENDIF + EXIT + END + + CASE nMode == 2 // Run in a foreach loop + aSubst := AClone( aParams ) + nSubstPos := AScan( aParams, {|x| ValType( x ) == "C" .and. x == "$."} ) + + SWITCH aDesc[1] + CASE 'A' // all results + FOR EACH oElem IN aDesc[ 2 ] + IF nSubstPos > 0 + aSubst[ nSubstPos ] := oElem + ENDIF + oRet := oFunc:Run( aSubst, Self ) + ::SendResult( oRet, cFuncName ) + NEXT + oRet := "Done" + EXIT + + CASE 'C' // Vector of all results + aRet := {} + ::lAllowProgress = .F. + FOR EACH oElem IN aDesc[ 2 ] + IF nSubstPos > 0 + aSubst[ nSubstPos ] := oElem + ENDIF + oRet := oFunc:Run( aSubst, Self ) + IF oRet == NIL + ::SendResult( NIL, cFuncName ) + EXIT + ENDIF + AAdd( aRet, oRet ) + NEXT + IF oRet != NIL + oRet := aRet + ENDIF + EXIT + + CASE 'E' // Just send confirmation at end + ::lAllowProgress = .F. + FOR EACH oElem IN aDesc[ 2 ] + IF nSubstPos > 0 + aSubst[ nSubstPos ] := oElem + ENDIF + oRet := oFunc:Run( aSubst, Self ) + IF oRet == NIL + EXIT + ENDIF + NEXT + EXIT + END + ENDCASE + + // Now we can signal that execution terminated + HB_MutexLock( ::mtxBusy ) + ::nStatus := RPCS_STATUS_LOGGED + HB_MutexUnlock( ::mtxBusy ) + // The execution of the function terminates BEFORE the sending of + // the last data or the confirmation data, even if the thread + // has still something to do. + ::SendResult( oRet, cFuncName ) + + //Signal that the thread is no longer alive + // Should not be needed! + /*HB_MutexLock( ::mtxBusy ) + ::thFunction := -1 + HB_MutexUnlock( ::mtxBusy )*/ +RETURN .T. + + +METHOD SendResult( oRet, cFuncName ) + LOCAL cData, cOrigLen, cCompLen + + // Ignore requests to send result if function is canceled + HB_MutexLock( ::mtxBusy ) + IF ::lCanceled + HB_MutexUnlock( ::mtxBusy ) + ::oServer:OnFunctionCanceled( Self, cFuncName ) + RETURN .T. //as if it were done + ENDIF + HB_MutexUnlock( ::mtxBusy ) + + IF oRet == NIL + ::oServer:OnFunctionError( Self, cFuncName, 10 ) + InetSendAll( ::skRemote, "XHBR4010" ) + ELSE + cData := HB_Serialize( oRet ) + cOrigLen := HB_CreateLen8( Len( cData ) ) + ::oServer:OnFunctionReturn( Self, cData ) + // should we compress it ? + + IF Len( cData ) > 512 + cData := HB_Compress( cData ) + cCompLen := HB_CreateLen8( Len( cData ) ) + InetSendAll( ::skRemote, "XHBR31" + cOrigLen + cCompLen + ::Encrypt( cData ) ) + ELSE + InetSendAll( ::skRemote, "XHBR30" + cOrigLen + ::Encrypt( cData ) ) + ENDIF + ENDIF + + IF InetErrorCode( ::skRemote ) != 0 + RETURN .F. + ENDIF + +RETURN .T. + + +METHOD SendProgress( nProgress, oData ) CLASS tRPCServeCon + LOCAL cOrigLen, cCompLen, lRet := .T. + LOCAL cData + + //Ignore if told so + HB_MutexLock( ::mtxBusy ) + IF .not. ::lAllowProgress .or. ::lCanceled + HB_MutexUnlock( ::mtxBusy ) + RETURN .T. + ENDIF + HB_MutexUnlock( ::mtxBusy ) + + ::oServer:OnFunctionProgress( Self, nProgress, oData ) + IF Empty( oData ) + InetSendAll( ::skRemote, "XHBR33" + HB_Serialize( nProgress ) ) + ELSE + cData := HB_Serialize( oData ) + cOrigLen := HB_CreateLen8( Len( cData ) ) + // do we should compress it ? + IF Len( cData ) > 512 + cData := HB_Compress( cData ) + cCompLen := HB_CreateLen8( Len( cData ) ) + InetSendAll(::skRemote, "XHBR35" + HB_Serialize( nProgress ) +; + cOrigLen + cCompLen + ::Encrypt( cData ) ) + ELSE + InetSendAll( ::skRemote, "XHBR34" + HB_Serialize( nProgress ) +; + cOrigLen + ::Encrypt( cData ) ) + ENDIF + ENDIF + + IF InetErrorCode( ::skRemote ) != 0 + lRet := .F. + ENDIF + +RETURN lRet + + +METHOD Encrypt(cDataIn) CLASS tRPCServeCon + IF ::bEncrypted + RETURN HB_Crypt( cDataIn, ::cCryptKey ) + ENDIF +RETURN cDataIn + + +METHOD Decrypt(cDataIn) CLASS tRPCServeCon + IF ::bEncrypted + RETURN HB_Decrypt( cDataIn, ::cCryptKey ) + ENDIF +RETURN cDataIn + +/************************************ +* RPC SERVICE +*************************************/ + +CLASS tRPCService + DATA cServerName INIT "RPCGenericServer" + DATA aFunctions + CLASSDATA lInit INIT InetInit() + + DATA nUdpPort INIT 1139 + DATA nTcpPort INIT 1140 + DATA cBindAddress INIT NIL + DATA thAccept INIT 0 + DATA thUdp INIT 0 + DATA aServing INIT {} + DATA mtxBusy INIT HB_MutexCreate() + + DATA skUdp + DATA skServer + + /* Code blocks corresponding to event handlers */ + DATA bAuthorize + DATA bGetEncryption + DATA bOnFunctionScan + DATA bOnServerScan + DATA bOnClientConnect + DATA bOnClientLogin + DATA bOnClientRequest + DATA bOnFunctionProgress + DATA bOnFunctionError + DATA bOnFunctionReturn + DATA bOnFunctionCanceled + DATA bOnClientLogout + DATA bOnClientTerminate + + METHOD New() CONSTRUCTOR + + /* Block run on client connection request */ + DATA bConnection + + /* Function management */ + METHOD Add( xFunction, cVersion, nId, oExec, oMethod ) + METHOD Run( cName, aParams ) + METHOD Describe( cName ) + METHOD Find( cName ) + METHOD Remove( cName ) + + /* General services */ + METHOD Start( lStartUdp ) + METHOD Stop() + METHOD StartService( skIn ) + METHOD Terminating( oConnection ) + + /* Tcp services */ + METHOD Accept() + + /* UDP services */ + METHOD UdpListen() + METHOD UDPParseRequest() + METHOD UDPInterpretRequest( cData, nPacketLen, cRes ) + + /* Utility */ + METHOD AuthorizeChallenge( cUserid, cPassword ) + + /* to be overloaded */ + METHOD Authorize( cUserid, cPassword ) + /* Provide encryption key for a user */ + METHOD GetEncryption( cUserId ) + METHOD OnFunctionScan() + METHOD OnServerScan( ) + METHOD OnClientConnect( oClient ) + METHOD OnClientLogin( oClient ) + METHOD OnClientRequest( oClient, nRequest, cData ) + METHOD OnFunctionProgress( oClient, nProgress, aData ) + METHOD OnFunctionError( oClient, cFuncName, nError ) + METHOD OnFunctionReturn( oClient, aData ) + METHOD OnFunctionCanceled( oClient, cFuncName ) + METHOD OnClientLogout( oClient ) + METHOD OnClientTerminate( oClient ) + +ENDCLASS + + +METHOD New() class tRPCService + ::aFunctions := {} +RETURN Self + + +METHOD Add( xFunction, cVersion, nLevel, oExec, oMethod ) + LOCAL nElem, lRet := .F. + LOCAL oFunction + + IF ValType( xFunction ) == "C" + oFunction := TRpcFunction():New( xFunction, cVersion, nLevel, oExec, oMethod ) + ELSE + oFunction := xFunction + ENDIF + + HB_MutexLock( ::mtxBusy ) + nElem := AScan( ::aFunctions, {|x| oFunction:cName == x:cName}) + IF nElem == 0 + Aadd( ::aFunctions , oFunction ) + lRet := .T. + ENDIF + HB_MutexUnlock( ::mtxBusy ) +RETURN lRet + + +METHOD Find( cName ) class tRPCService + LOCAL nElem + LOCAL oRet := NIL + + HB_MutexLock( ::mtxBusy ) + nElem := AScan( ::aFunctions, {|x| upper(cName) == upper(x:cName)}) + IF nElem != 0 + oRet := ::aFunctions[ nElem ] + ENDIF + HB_MutexUnlock( ::mtxBusy ) +RETURN oRet + + +METHOD Remove( cName ) class tRPCService + LOCAL nElem + LOCAL lRet := .F. + + HB_MutexLock( ::mtxBusy ) + nElem := AScan( ::aFunctions, {|x| cName == x:cName}) + IF nElem != 0 + ADel( ::aFunctions, nElem ) + ASize( ::aFunctions, Len( ::aFunctions ) - 1 ) + lRet := .T. + ENDIF + HB_MutexUnlock( ::mtxBusy ) +RETURN lRet + + +METHOD Run( cName, aParams ) class tRPCService + LOCAL oFunc := ::Find( cName ) + LOCAL oRet := NIL + + HB_MutexLock( ::mtxBusy ) + IF ! Empty( oFunc ) + oRet := oFunc:Run( aParams ) + ENDIF + HB_MutexUnlock( ::mtxBusy ) + +RETURN oRet + + +METHOD Describe( cName ) class tRPCService + LOCAL oFunc := ::Find( cName ) + LOCAL cRet := NIL + + HB_MutexLock( ::mtxBusy ) + IF ! Empty( oFunc ) + cRet := oFunc:Describe() + ENDIF + HB_MutexUnlock( ::mtxBusy ) + +RETURN cRet + + +METHOD Start( lStartUdp ) CLASS tRPCService + + IF Empty( ::cBindAddress ) + ::skServer := InetServer( ::nTcpPort ) + ::skUdp := InetDGramBind( ::nUdpPort ) + ELSE + ::skServer := InetServer( ::nTcpPort, ::cBindAddress ) + ::skUdp := InetDGramBind( ::nUdpPort, ::cBindAddress ) + ENDIF + + ::thAccept := StartThread( Self, "Accept" ) + + IF lStartUdp != NIL .and. lStartUdp + ::thUdp := StartThread( Self, "UdpListen" ) + ELSE + ::thUdp := NIL + ENDIF + +RETURN .T. + + +METHOD Stop() CLASS tRPCService + LOCAL oElem + + HB_MutexLock( ::mtxBusy ) + IF .not. IsValidThread( ::thAccept ) + HB_MutexUnlock( ::mtxBusy ) + RETURN .F. + ENDIF + + InetClose( ::skServer ) + // closing the socket will make their infinite loops to terminate. + StopThread( ::thAccept) + JoinThread( ::thAccept ) + IF IsValidThread( ::thUDP ) + InetClose( ::skUdp ) + StopThread( ::thUdp) + JoinThread( ::thUdp ) + ENDIF + + FOR EACH oElem IN ::aServing + IF IsValidThread( oElem:thSelf ) + KillThread( oElem:thSelf ) + JoinThread( oElem:thSelf ) + ENDIF + NEXT + ASize( ::aServing, 0 ) + + // now destroy all the allocated resources + ::skServer := NIL + ::skUdp := NIL + + HB_MutexUnlock( ::mtxBusy ) + +RETURN .T. + + +METHOD Accept() CLASS tRPCService + LOCAL skIn + + DO WHILE .T. + skIn := InetAccept( ::skServer ) + // todo: better sync + IF InetStatus( ::skServer ) < 0 + EXIT + ENDIF + IF skIn != NIL + ::StartService( skIn ) + ENDIF + ENDDO +RETURN .T. + + +METHOD StartService( skIn ) CLASS tRPCService + LOCAL oService + + HB_MutexLock( ::mtxBusy ) + oService := tRpcServeCon():New( Self, skIn ) + AAdd( ::aServing, oService ) + oService:Start() + HB_MutexUnlock( ::mtxBusy ) + ::OnClientConnect( oService ) +RETURN .T. + +METHOD UDPListen( ) CLASS tRPCService + LOCAL cData := Space( 1000 ) + LOCAL nPacketLen + + DO WHILE .T. + nPacketLen := InetDGramRecv( ::skUdp, @cData, 1000 ) + IF InetStatus( ::skUdp ) < 0 + EXIT + ENDIF + ::UDPParseRequest( cData, nPacketLen ) + ENDDO +RETURN .T. + +METHOD UDPParseRequest( cData, nPacketLen ) CLASS tRPCService + LOCAL cToSend + + IF ::UDPInterpretRequest( cData, nPacketLen, @cToSend ) + InetDGramSend( ::skUdp, ; + InetAddress( ::skUdp ), InetPort( ::skUdp ), cToSend ) + RETURN .T. + ENDIF +RETURN .F. + +METHOD UDPInterpretRequest( cData, nPacketLen, cRes ) CLASS tRPCService + LOCAL cCode, cMatch, cNumber, cSerial + LOCAL oFunc + + IF nPacketLen < 6 + RETURN .F. + ENDIF + + cCode := Substr( cData, 1, 6 ) + + DO CASE + + /* XHRB00 - server scan */ + CASE cCode == "XHBR00" + IF .not. ::OnServerScan() + RETURN .F. + ENDIF + IF nPacketLen > 6 + cMatch := HB_Deserialize( Substr( cData, 7 ) ) + IF HB_RegexMatch( cMatch, ::cServerName ) + cRes := "XHBR10"+ HB_Serialize( ::cServerName ) + ENDIF + ELSE + cRes := "XHBR10"+ HB_Serialize( ::cServerName ) + ENDIF + RETURN .T. + + /* XRB01 - Function scan */ + CASE cCode == "XHBR01" + IF .not. ::OnFunctionScan() + RETURN .F. + ENDIF + /* minimal length to be valid */ + IF nPacketLen > 24 + cSerial := HB_DeserialBegin( Substr( cData, 7 ) ) + cMatch := HB_DeserialNext( @cSerial ) + cNumber := NIL + IF .not. Empty ( cMatch ) + cMatch := HB_RegexComp( cMatch ) + cNumber := HB_DeserialNext( @cSerial ) + ELSE + cMatch := HB_RegexComp( ".*" ) + ENDIF + + IF Empty( cNumber ) + cNumber := "00000000.0" + ENDIF + + FOR EACH oFunc IN ::aFunctions + IF HB_RegexMatch( cMatch, oFunc:cName ) .and. cNumber <= oFunc:cSerial + cRes := "XHBR11" + HB_Serialize(::cServerName ) + ; + HB_Serialize( ofunc:Describe()) + RETURN .T. + ENDIF + NEXT + ENDIF + + /* If we don't have the function, we cannot reply */ + RETURN .F. + + ENDCASE + + /* Ignore malfored requests. */ +RETURN .F. + + +METHOD Terminating( oConnection ) CLASS tRPCService + LOCAL nToken + + ::OnClientTerminate( oConnection ) + HB_MutexLock( ::mtxBusy ) + nToken := AScan( ::aServing, {|x| x == oConnection } ) + IF nToken > 0 + ADel( ::aServing, nToken ) + ASize( ::aServing, Len( ::aServing ) -1 ) + ENDIF + HB_MutexUnlock( ::mtxBusy ) +RETURN .T. + + +METHOD AuthorizeChallenge( cUserId, cData ) CLASS tRPCService + LOCAL cKey, nPos, cMarker := "PASSWORD:" + + cKey := ::GetEncryption( cUserId ) + IF Empty( cKey ) + RETURN NIL + ENDIF + + cData := HB_Decrypt( cData, cKey ) + nPos := At( cMarker, cData ) + IF nPos == 0 + RETURN NIL + ENDIF + + cData := Substr( cData, nPos + Len( cMarker ) ) + nPos := At( ":", cData ) + IF nPos == 0 + RETURN NIL + ENDIF + + cData := Substr( cData, 1, nPos - 1 ) + + IF ::Authorize( cUserId, cData ) > 0 + RETURN cKey + ENDIF +RETURN NIL + +/* Default authorization will ALWAYS return 1 if a bAuthorize block is not provided */ +/* IF cPassword is NIL, must return the level of the given userid */ +METHOD Authorize( cUserid, cPassword ) CLASS tRPCService + IF ::bAuthorize != NIL + RETURN Eval( ::bAuthorize, cUserid, cPassword ) + ENDIF +RETURN 1 + +/* By default, do not provide an encryption key for any user */ +METHOD GetEncryption( cUserId ) CLASS tRPCService + IF ::bGetEncryption != NIL + RETURN Eval( ::bGetEncryption, cUserId ) + ENDIF +RETURN NIL + +METHOD OnFunctionScan() CLASS tRPCService + IF ::bOnFunctionScan != NIL + RETURN Eval( ::bOnFunctionScan, Self ) + ENDIF +RETURN .T. + +METHOD OnServerScan() CLASS tRPCService + IF ::bOnServerScan != NIL + RETURN Eval( ::bOnServerScan, Self ) + ENDIF +RETURN .T. + +METHOD OnClientConnect( oClient ) CLASS tRPCService + IF ::bOnClientConnect != NIL + RETURN Eval( ::bOnClientConnect, oClient ) + ENDIF +RETURN .T. + +METHOD OnClientLogin( oClient ) CLASS tRPCService + IF ::bOnClientLogin != NIL + Eval( ::bOnClientLogin, oClient ) + ENDIF +RETURN .T. + +METHOD OnClientRequest( oClient, nRequest, cData ) CLASS tRPCService + IF ::bOnClientRequest != NIL + RETURN Eval( ::bOnClientRequest, oClient, nRequest, cData ) + ENDIF +RETURN .T. + +METHOD OnFunctionProgress( oClient, nProgress, aData ) CLASS tRPCService + IF ::bOnFunctionProgress != NIL + RETURN Eval( ::bOnFunctionProgress, oClient, nProgress, aData ) + ENDIF +RETURN .T. + +METHOD OnFunctionError( oClient, cFunction, nError ) CLASS tRPCService + IF ::bOnFunctionError != NIL + RETURN Eval( ::bOnFunctionError, oClient, cFunction, nError ) + ENDIF +RETURN .T. + +METHOD OnFunctionReturn( oClient, aData ) CLASS tRPCService + IF ::bOnFunctionReturn != NIL + RETURN Eval( ::bOnFunctionReturn, oClient, aData ) + ENDIF +RETURN .T. + +METHOD OnFunctionCanceled( oClient, cFuncName ) CLASS tRPCService + IF ::bOnFunctionCanceled != NIL + RETURN Eval( ::bOnFunctionCanceled, oClient, cFuncName ) + ENDIF +RETURN .T. + +METHOD OnClientLogout( oClient ) CLASS tRPCService + IF ::bOnClientLogout != NIL + RETURN Eval( ::bOnClientLogout, oClient ) + ENDIF +RETURN .T. + +METHOD OnClientTerminate( oClient ) CLASS tRPCService + IF ::bOnClientTerminate != NIL + RETURN Eval( ::bOnClientTerminate, oClient ) + ENDIF +RETURN .T. diff --git a/harbour/contrib/xhb/trpccli.prg b/harbour/contrib/xhb/trpccli.prg new file mode 100644 index 0000000000..a3ed51bd11 --- /dev/null +++ b/harbour/contrib/xhb/trpccli.prg @@ -0,0 +1,1061 @@ +/* + * $Id$ + */ + +/* + * xHarbour Project source code: + * Remote Procedure Call code + * Client class + * + * Copyright 2003 Giancarlo Niccolai + * www - http://www.xharbour.org + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/). + * + * As a special exception, the Harbour Project gives permission for + * additional uses of the text contained in its release of Harbour. + * + * The exception is that, if you link the Harbour libraries with other + * files to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the Harbour library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the Harbour + * Project under the name Harbour. If you copy code from other + * Harbour Project or Free Software Foundation releases into a copy of + * Harbour, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for Harbour, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. + * + */ + +#include "hbclass.ch" + +#include "xhb.ch" + +#include "hbrpc.ch" + +CLASS tRPCClient + + DATA aServers + DATA aFunctions + + DATA nUdpPort + DATA nTcpPort + + /* asyncrhonous mode */ + DATA lAsyncMode + /* block to be called at scan completion */ + DATA bOnScanComplete + /*block called when there is a progress in the scan */ + DATA bOnScanServersProgress + DATA bOnScanFunctionsProgress + + /* block to be called at function error */ + DATA bOnFunctionProgress + /* block to be called at function success */ + DATA bOnFunctionReturn + /* block to be called at function failure */ + DATA bOnFunctionFail + + + METHOD New( cNetwork, nTcpPort, nUdpPort ) CONSTRUCTOR + METHOD Destroy() + + /* Connection */ + METHOD Connect( cServer, cUserId, cPassword ) + METHOD Disconnect() + + /* Network scan functions */ + METHOD ScanServers( cName ) + METHOD ScanFunctions( cName, cSerial ) + METHOD ScanAgain() INLINE ::UDPAccept() + METHOD StopScan() + + /* Function call */ + METHOD CheckServer() //Checks if a server is ready on tcp + METHOD SetLoopMode( nMethod, xData, nEnd, nStep ) + METHOD Call() // variable parameters + METHOD CallAgain() INLINE ::TCPAccept() + METHOD StopCall() + + METHOD SetPeriodCallback() + METHOD ClearPeriodCallback() + + + /* Accessors */ + METHOD SetEncryption( cKey ) + METHOD IsEncrypted() INLINE ::cCryptKey != NIL + METHOD GetStatus() INLINE ::nStatus + METHOD SetTimeout( nTime ) + METHOD GetTimeout() + METHOD GetResult() INLINE ::oResult + METHOD FoundServers() INLINE Len( ::aServers ) != 0 + METHOD FoundFunctions() INLINE Len( ::aFunctions ) != 0 + + METHOD HasError() INLINE ::nErrorCode != 0 .or. ::TcpHasError() .or. ::UdpHasError() + METHOD GetErrorCode() INLINE ::nErrorCode + + METHOD TcpHasError() INLINE IIF( Empty( ::skTCP ), .F., InetErrorCode( ::skTCP ) > 0 ) + METHOD GetTcpErrorCode() INLINE IIF( Empty( ::skTCP ), 0, InetErrorCode( ::skTCP ) ) + METHOD GetTcpErrorDesc() INLINE IIF( Empty( ::skTCP ), "", InetErrorDesc( ::skTCP ) ) + + METHOD UdpHasError() INLINE IIF( Empty( ::skUDP ), .F., InetErrorCode( ::skUDP ) > 0 ) + METHOD UdpGetErrorCode() INLINE IIF( Empty( ::skUDP ), 0, InetErrorCode( ::skUDP ) ) + METHOD UdpGetErrorDesc() INLINE IIF( Empty( ::skUDP ), "", InetErrorDesc( ::skUDP ) ) + /* Used to retreive data from scans */ + METHOD GetFunctionName( xId ) + METHOD GetServerName( xId ) + METHOD GetServerAddress( xId ) + +HIDDEN: + // Automatic initialization of inet support + CLASSDATA lInit INIT InetInit() + + DATA mtxBusy INIT HB_MutexCreate() + + DATA nStatus + // This RPC protocol breaking error code + DATA nErrorCode + + /* Network data */ + DATA cServer + DATA cNetwork + DATA skUdp + DATA skTcp + + /* Timeout system */ + DATA nTimeout INIT -1 + DATA nTimeLimit INIT -1 + DATA caPerCall + + DATA nUdpTimeBegin INIT 0 + DATA thUdpAccept INIT NIL + + DATA nTcpTimeBegin INIT 0 + DATA thTcpAccept INIT NIL + + /* XHB RPC Loop system */ + DATA nLoopMode + DATA aLoopData + DATA nLoopStart + DATA nLoopEnd + DATA nLoopStep + + /* Encryption data */ + DATA bEncrypted + DATA cCryptKey + + /* Last connection result */ + DATA oResult + + /* Encryption system */ + METHOD Encrypt( cData ) + METHOD Decrypt( cData ) + METHOD BuildChallengePwd( cPassword ) + METHOD ManageChallenge() + + /* Network negotiation system */ + METHOD StartScan() + METHOD UDPAccept() + METHOD UDPParse( cData, nLen ) + METHOD TCPAccept() + METHOD TCPParse( cData ) + METHOD clearTCPBuffer() + + /* internal network send call */ + METHOD SendCall(cFunction,aParams ) + + /* event handlers */ + METHOD OnScanComplete() + METHOD OnScanServersProgress( aLoc ) + METHOD OnScanFunctionsProgress( aLoc ) + + METHOD OnFunctionFail( nReason, cReason ) + METHOD OnFunctionReturn( oReturn ) + METHOD OnFunctionProgress( nProgress, oData ) + +ENDCLASS + + +METHOD New( cNetwork, nTcpPort, nUdpPort ) CLASS tRPCClient + ::nStatus := RPC_STATUS_NONE // not connected + ::nErrorCode := 0 // no RPC error + ::cServer := NIL // no server + + ::nUdpPort := IIF( nUdpPort == NIL, 1139, nUdpPort ) + ::nTcpPort := IIF( nTcpPort == NIL, 1140, nTcpPort ) + + ::skTcp := InetCreate() + ::skUdp := InetDGram( .T. ) + ::lAsyncMode := .F. + ::aServers := {} + ::aFunctions := {} + ::cNetwork := cNetwork + ::bEncrypted := .F. + + ::nLoopMode := RPC_LOOP_NONE +RETURN Self + + +METHOD Destroy() CLASS tRPCClient + + HB_MutexLock( ::mtxBusy ) + + ::Disconnect() + IF IsValidThread( ::thUdpAccept ) + KillThread( ::thUdpAccept ) + ::thUdpAccept := NIL + ENDIF + IF IsValidThread( ::thTcpAccept ) + KillThread( ::thTcpAccept ) + ::thTcpAccept := NIL + ENDIF + HB_MutexUnlock( ::mtxBusy ) +RETURN .T. + + +METHOD SetEncryption( cKey ) + IF .not. Empty( cKey ) + ::bEncrypted := .T. + ::cCryptKey := cKey + ELSE + ::bEncrypted := .F. + ENDIF +RETURN .T. + + +METHOD ScanServers(cName) CLASS tRPCClient + // do not allow asynchronous mode without timeout + IF .not. ::lAsyncMode .and. ( ::nTimeout == NIL .or. ::nTimeOut <= 0 ) + RETURN .F. + ENDIF + + HB_MutexLock( ::mtxBusy ) + ::aServers = {} + HB_MutexUnlock( ::mtxBusy ) + + InetDGramSend( ::skUDP, ::cNetwork , ::nUdpPort, "XHBR00" + HB_Serialize( cName ) ) + ::StartScan() + +RETURN .F. + +METHOD CheckServer( cRemote ) + LOCAL cData, skRemote, nLen, cData2 + + cData := "XHBR00" + IF cRemote == NIL + cRemote := ::cNetwork + ENDIF + skRemote := InetConnect( cRemote, ::nTcpPort ) + IF InetErrorCode( skRemote ) == 0 + InetSetTimeout(skRemote, 10000) + InetSendAll( skRemote, cData ) + cData := space(256) + InetRecvAll( skRemote, @cData, 6+9 ) + IF InetErrorCode( skRemote ) == 0 + cData2 := Space(256) + nLen := HB_GetLen8( substr( cData, 8, 8 ) ) + InetRecvAll( skRemote, @cData2, nLen ) + IF InetErrorCode( skRemote ) == 0 + cData := Substr( cData + cData2, 7 ) + cData2 := HB_Deserialize( cData ) + AAdd(::aServers, {InetAddress( skRemote ), cData2} ) + RETURN .T. + ENDIF + ENDIF + ENDIF +RETURN .F. + +METHOD ScanFunctions(cFunc, cSerial ) CLASS tRPCClient + // do not allow asynchronous mode without timeout + IF .not. ::lAsyncMode .and. ( ::nTimeOut == NIL .or. ::nTimeOut <= 0 ) + RETURN .F. + ENDIF + + IF cSerial == NIL + cSerial := "00000000.0" + ENDIF + HB_MutexLock( ::mtxBusy ) + ::aFunctions = {} + ::aServers = {} + HB_MutexUnlock( ::mtxBusy ) + + InetDGramSend( ::skUDP, ::cNetwork, ::nUdpPort,; + "XHBR01" + HB_Serialize( cFunc ) + HB_Serialize( cSerial )) + ::StartScan() + +RETURN .F. + + +METHOD StartScan() + // We don't accept sync call without timeout + + IF ::lAsyncMode + // in async mode, force scanning stop + ::StopScan() + ENDIF + + ::nUDPTimeBegin := INT( Seconds() * 1000 ) + + // in async mode, just launch the listener + IF ::lAsyncMode + HB_MutexLock( ::mtxBusy ) + ::thUdpAccept := StartThread( Self, "UDPAccept" ) + HB_MutexUnlock( ::mtxBusy ) + ELSE + ::UDPAccept() + ENDIF + +RETURN .T. + + +METHOD UDPAccept() CLASS tRPCClient + LOCAL nTime, nDatalen, cData + + cData := Space( 1400 ) + // set default socket timeout + IF ::nTimeout >= 0 + InetSetTimeout( ::skUDP, ::nTimeout ) + ELSE + InetClearTimeout( ::skUdp ) + ENDIF + + DO WHILE .T. + nDatalen := InetDGramRecv( ::skUDP, @cData, 1400 ) + + IF nDataLen > 0 .and. ::UDPParse( cData, nDatalen ) + EXIT + ENDIF + + IF ::nTimeout >= 0 + nTime := Int( Seconds() * 1000 ) + // a little tollerance must be added for double roundings + // in the double INT() functions + IF nTime - ::nUDPTimeBegin >= ::nTimeout - 5 + EXIT + ENDIF + ENDIF + + ENDDO + + ::OnScanComplete() + // signal that this thread is no longer active + HB_MutexLock( ::mtxBusy ) + ::thUdpAccept := NIL + HB_MutexUnlock( ::mtxBusy ) + +RETURN .T. + + +METHOD UDPParse( cData, nLen ) CLASS tRPCClient + LOCAL cCode, cSer, cFunc, cName + LOCAL aLoc + + IF nLen < 12 + RETURN .F. + ENDIF + + cCode := Substr( cData, 1, 6 ) + + DO CASE + /* XHRB00 - server scan */ + CASE cCode == "XHBR10" + cData := Substr( cData, 7 ) + cData := HB_Deserialize( cData, 512 ) + // deserialization error checking + IF cData != NIL + aLoc := { InetAddress( ::skUDP ), cData } + AAdd( ::aServers, aLoc ) + RETURN ::OnScanServersProgress( aLoc ) + ELSE + RETURN .F. + ENDIF + + + CASE cCode == "XHBR11" + cData := Substr( cData, 7 ) + cSer := HB_DeserialBegin( cData ) + cName := HB_DeserialNext( @cSer, 64 ) + cFunc := HB_DeserialNext( @cSer, 64 ) + IF cName != NIL .and. cFunc != NIL + aLoc := { InetAddress( ::skUDP ), cName, cFunc } + AAdd( ::aFunctions, aLoc ) + RETURN ::OnScanFunctionsProgress( aLoc ) + ELSE + RETURN .F. + ENDIF + + ENDCASE + +RETURN .F. + + +METHOD StopScan() CLASS tRPCClient + HB_MutexLock( ::mtxBusy ) + IF IsValidThread( ::thUDPAccept ) + KillThread( ::thUDPAccept ) + ::thUDPAccept := NIL + HB_MutexUnlock( ::mtxBusy ) + ::OnScanComplete() + ELSE + HB_MutexUnlock( ::mtxBusy ) + ENDIF +RETURN .T. + + +METHOD Connect( cServer, cUserId, cPassword ) CLASS tRPCClient + LOCAL cAuth, cReply := Space(8) + + InetConnect( cServer, ::nTcpPort, ::skTcp ) + + IF InetErrorCode( ::skTcp ) == 0 + ::nStatus := RPC_STATUS_CONNECTED // Connected + IF ::bEncrypted + cAuth := ::BuildChallengePwd( cPassword ) + cAuth := cUserId + ":" + cAuth + InetSendAll( ::skTcp, "XHBR93" + HB_CreateLen8( Len( cAuth ) ) + cAuth ) + ELSE + cAuth := cUserId + ":" + cPassword + InetSendAll( ::skTcp, "XHBR90" + HB_CreateLen8( Len( cAuth ) ) + cAuth ) + ENDIF + + IF InetErrorCode( ::skTcp ) == 0 + IF .not. ::bEncrypted + InetRecvAll( ::skTcp, @cReply ) + IF InetErrorCode( ::skTcp ) == 0 .and. cReply == "XHBR91OK" + ::nStatus := RPC_STATUS_LOGGED // Logged in + RETURN .T. + ENDIF + ELSE + RETURN ::ManageChallenge() + ENDIF + + ENDIF + ENDIF + + ::skTcp := NIL + ::nStatus := RPC_STATUS_NONE +RETURN .F. + + +METHOD BuildChallengePwd( cPassword ) CLASS tRPCClient + LOCAL nLen, nCount, cRet + + nLen := 10 + INT( HB_Random( 1, 60 ) ) + + cRet := "" + + FOR nCount := 1 TO nLen + cRet += Chr( Int( HB_Random( 2, 254 ) ) ) + NEXT + cRet += "PASSWORD:" + cPassword + ":" + + DO WHILE Len( cRet ) < 100 + cRet += Chr( Int( HB_Random( 2, 254 ) ) ) + ENDDO + + cRet := ::Encrypt( cRet ) +RETURN cRet + + +METHOD ManageChallenge() CLASS tRPCClient + LOCAL cCode, cLen, nLen + LOCAL cData, nChallenge + + cCode := Space( 6 ) + IF InetRecvAll( ::skTCP, @cCode ) != 6 + RETURN .F. + ENDIF + + IF cCode != "XHBR94" + RETURN .F. + ENDIF + + cLen := Space( 8 ) + IF InetRecvAll( ::skTCP, @cLen ) != 8 + RETURN .F. + ENDIF + + nLen := HB_GetLen8( cLen ) + cData := Space( nLen ) + IF InetRecvAll( ::skTCP, @cData, nLen ) != nLen + RETURN .F. + ENDIF + + cData := HB_Decrypt( cData, ::cCryptKey ) + nChallenge := HB_Checksum( cData ) + InetSendAll( ::skTCP, "XHBR95" + HB_CreateLen8( nChallenge ) ) + //IF InetErrorCode( ::skTCP ) != 0 + // RETURN .F. + //ENDIF + + cCode := Space( 8 ) + InetRecvAll( ::skTCP, @cCode ) + IF InetErrorCode( ::skTCP ) != 0 .or. cCode != "XHBR91OK" + RETURN .F. + ENDIF + /* SUCCESS! */ + ::nStatus := RPC_STATUS_LOGGED + +RETURN .T. + + +METHOD Disconnect() CLASS tRPCClient + + IF ::nStatus >= RPC_STATUS_LOGGED + HB_MutexLock( ::mtxBusy ) + ::nStatus := RPC_STATUS_NONE + InetSendAll( ::skTcp, "XHBR92" ) + InetClose( ::skTcp ) + HB_MutexUnlock( ::mtxBusy ) + RETURN .T. + ENDIF + +RETURN .F. + + + +METHOD SetLoopMode( nMethod, xData, nEnd, nStep ) CLASS tRPCClient + + IF nMethod == RPC_LOOP_NONE + ::nLoopMode := RPC_LOOP_NONE + ::aLoopData := NIL + RETURN .T. + ENDIF + + IF ValType( xData ) == "A" + ::aLoopData := xData + ELSE + IF ValType( xData ) == "NI" + // this is to allow garbage collecting + ::aLoopData := NIL + ::nLoopStart := xData + ::nLoopEnd := nEnd + IF ValType( nStep ) == "NI" + ::nLoopStep := nStep + ELSE + ::nLoopStep := 1 + ENDIF + ELSE + RETURN .F. + ENDIF + ENDIF + + ::nLoopMode := nMethod + +RETURN .T. + +METHOD ClearTCPBuffer() CLASS tRPCClient + LOCAL cDummy := Space( 512 ) + + IF ::skTCP == NIL .or. ::nStatus < RPC_STATUS_LOGGED + RETURN .F. + ENDIF + + DO WHILE InetDataReady( ::skTCP ) > 0 + // InetRecv reads only the available data + InetRecv( ::skTCP, @cDummy ) + ENDDO +RETURN .T. + + +METHOD Call( ... ) CLASS tRPCClient + LOCAL oCalling + LOCAL cFunction, aParams + LOCAL nCount + + IF Pcount() == 0 + RETURN NIL + ENDIF + + ::oResult := NIL + + // do not allow asynchronous mode without timeout + IF .not. ::lAsyncMode .and. ( ::nTimeOut == NIL .or. ::nTimeOut <= 0 ) + RETURN NIL + ENDIF + + oCalling := PValue( 1 ) + IF ValType( oCalling ) == "A" + cFunction := oCalling[1] + ADel( oCalling, 1 ) + ASize( oCalling, Len( oCalling ) -1 ) + aParams := oCalling + ELSE + cFunction := oCalling + aParams := Array( Pcount() -1 ) + FOR nCount := 2 TO Pcount() + aParams[nCount - 1] := PValue( nCount ) + NEXT + ENDIF + + // clear eventual pending data + ::ClearTcpBuffer() + + // The real call + HB_MutexLock( ::mtxBusy ) + // already active or not already connected + IF IsValidThread( ::thTcpAccept ) .or. ::skTCP == NIL .or. ::nStatus < RPC_STATUS_LOGGED + HB_MutexUnlock( ::mtxBusy ) + RETURN NIL + ENDIF + HB_MutexUnlock( ::mtxBusy ) + + ::nStatus := RPC_STATUS_WAITING // waiting for a reply + + // send the call through the socket + IF .not. ::SendCall( cFunction, aParams ) + RETURN .F. + ENDIF + + // in async mode, just launch the listener + IF ::lAsyncMode + HB_MutexLock( ::mtxBusy ) + ::thTCPAccept := StartThread( Self, "TCPAccept" ) + HB_MutexUnlock( ::mtxBusy ) + ELSE + ::TCPAccept() + ENDIF + +RETURN ::oResult + + +METHOD SetPeriodCallback( ... ) CLASS tRPCClient + LOCAL caCalling + LOCAL nCount + + IF Pcount() < 3 + //TODO set an error + RETURN .F. + ENDIF + + HB_MutexLock( ::mtxBusy ) + ::nTimeout := PValue( 1 ) + ::nTimeLimit := PValue( 2 ) + + caCalling := PValue( 3 ) + IF ValType( caCalling ) != "A" + caCalling := Array( Pcount() -2 ) + FOR nCount := 3 TO Pcount() + caCalling[nCount - 2] := PValue( nCount ) + NEXT + ENDIF + ::caPerCall := caCalling + + IF ::skTCP != NIL + InetSetTimeout( ::skTCP, ::nTimeout ) + InetSetTimeLimit( ::skTCP, ::nTimeLimit ) + InetSetPeriodCallback( ::skTCP, caCalling ) + ENDIF + + HB_MutexUnlock( ::mtxBusy ) + +RETURN .T. + + +METHOD ClearPeriodCallback() CLASS tRPCClient + HB_MutexLock( ::mtxBusy ) + + ::nTimeout := -1 + ::nTimeLimit := -1 + ::caPerCall := NIL + + IF ::skTCP != NIL + InetClearTimeout( ::skTCP ) + InetClearTimeLimit( ::skTCP ) + InetClearPeriodCallback( ::skTCP ) + ENDIF + + HB_MutexUnlock( ::mtxBusy ) +RETURN .T. + + +METHOD SetTimeout( nTime ) CLASS tRPCClient + HB_MutexLock( ::mtxBusy ) + + ::nTimeout := nTime + InetSetTimeout( ::skTCP, ::nTimeout ) + + HB_MutexUnlock( ::mtxBusy ) +RETURN .T. + + +METHOD GetTimeout() + LOCAL nRet + HB_MutexLock( ::mtxBusy ) + nRet := ::nTimeout + HB_MutexUnlock( ::mtxBusy ) +RETURN nRet + + +METHOD StopCall() CLASS tRPCClient + + IF ::nStatus != RPC_STATUS_WAITING + RETURN .F. + ENDIF + + // clear eventual pending data + ::ClearTcpBuffer() + + // send cancelation request + InetSendAll( ::skTCP, "XHBR29" ); + + //Stops waiting for a result + HB_MutexLock( ::mtxBusy ) + IF IsValidThread( ::thTCPAccept ) + KillThread( ::thTCPAccept ) + ::thTCPAccept := NIL + ::nStatus := RPC_STATUS_LOGGED + HB_MutexUnlock( ::mtxBusy ) + ::OnFunctionReturn( NIL ) + ELSE + HB_MutexUnlock( ::mtxBusy ) + ENDIF + +RETURN .T. + + +METHOD SendCall( cFunction, aParams ) CLASS tRPCClient + LOCAL cData := "", nLen + LOCAL nReq, cType + + SWITCH ::nLoopMode + CASE RPC_LOOP_NONE + nReq = 0 + cType = "" + EXIT + + CASE RPC_LOOP_ALLDATA + nReq = 2 + cType = "A" + EXIT + + CASE RPC_LOOP_SUMMARY + nReq = 2 + cType = "C" + EXIT + + CASE RPC_LOOP_CONFIRMATION + nReq = 2 + cType = "E" + EXIT + END + + IF ::aLoopData == NIL .and. ::nLoopMode > RPC_LOOP_NONE + cData := HB_Serialize( ::nLoopStart ) + HB_Serialize( ::nLoopEnd ) +; + HB_Serialize( ::nLoopStep ) + ENDIF + + cData += HB_Serialize( cFunction ) + HB_Serialize( aParams ) + + IF ::aLoopData != NIL + cData += HB_Serialize( ::aLoopData ) + nReq += 2 + ENDIF + + nLen := Len( cData ) + IF nLen > 512 + cData := HB_Compress( cData ) + cData := "XHBR2" + AllTrim( Str( nReq + 1 ) ) + ; + HB_CreateLen8( nLen ) + HB_CreateLen8( Len( cData ) ) +; + cType + ::Encrypt( cData ) + ELSE + cData := "XHBR2" + AllTrim( Str( nReq ) ) + HB_CreateLen8( nLen ) +; + cType + ::Encrypt( cData) + ENDIF + + InetSendAll( ::skTCP, cData ) +RETURN ( InetErrorCode( ::skTCP ) == 0 ) + + +METHOD TCPAccept() CLASS tRPCClient + LOCAL nTime := 0 + LOCAL cCode + LOCAL nTimeLimit + + // TcpAccept can also be called standalone, without the + // support of call(). So, we must set the waiting state. + HB_MutexLock( ::mtxBusy ) + + ::nErrorCode := 0 + ::nStatus := RPC_STATUS_WAITING + + HB_MutexUnlock( ::mtxBusy ) + + cCode := Space(6) + ::nTCPTimeBegin := INT( Seconds() * 1000 ) + nTimeLimit = Max( ::nTimeout, ::nTimeLimit ) + + + DO WHILE .T. + IF InetRecvAll( ::skTCP, @cCode, 6 ) <= 0 + EXIT + ENDIF + + IF .not. ::TCPParse( cCode ) + EXIT + ENDIF + + IF nTimeLimit >= 0 + nTime := Int( Seconds() * 1000 ) + // a little tollerance must be added for double roundings + // in the double INT() functions + IF nTime - ::nTCPTimeBegin >= nTimeLimit - 5 + EXIT + ENDIF + ENDIF + ENDDO + + HB_MutexLock( ::mtxBusy ) + + // NOT waiting anymore + ::nStatus := RPC_STATUS_LOGGED + ::thTcpAccept := NIL + + IF ::caPerCall == NIL .and. InetErrorCode( ::skTCP ) != -1 .and.; + nTime - nTimeLimit < nTimeLimit - 5 + IF InetErrorCode( ::skTCP ) != 0 + ::nStatus := RPC_STATUS_ERROR + ENDIF + ENDIF + + HB_MutexUnlock( ::mtxBusy ) + +RETURN .T. + + +METHOD TCPParse( cCode ) CLASS tRPCClient + LOCAL nDataLen, cData, nOrigLen + LOCAL cDataLen := Space( 8 ), cOrigLen := Space( 8 ) + LOCAL cProgress := Space( 10 ), nProgress + LOCAL lContinue := .F. + + ::nErrorCode := 0 + + DO CASE + /* Warn error codes */ + CASE cCode == "XHBR40" + cData := Space(2) + InetRecvAll( ::skTCP, @cData, 2 ) + ::nErrorCode := Val( cData ) + ::OnFunctionFail( ::nErrorCode, "No description for now" ) + + /* We have a reply */ + CASE cCode == "XHBR30" + IF InetRecvAll( ::skTCP, @cDataLen ) == Len( cDataLen ) + nDataLen := HB_GetLen8( cDataLen ) + cData := Space( nDataLen ) + IF InetRecvAll( ::skTCP, @cData, nDataLen ) == nDataLen + ::oResult := HB_Deserialize( ::Decrypt( cData ), nDataLen ) + IF ::oResult != NIL + ::OnFunctionReturn( ::oResult ) + ENDIF + // todo: rise an error if ::oResult is nil + ENDIF + ENDIF + + /* We have a reply */ + CASE cCode == "XHBR31" + IF InetRecvAll( ::skTCP, @cOrigLen ) == Len( cOrigLen ) + nOrigLen = HB_GetLen8( cOrigLen ) + IF InetRecvAll( ::skTCP, @cDataLen ) == Len( cDataLen ) + nDataLen := HB_GetLen8( cDataLen ) + cData := Space( nDataLen ) + IF InetRecvAll( ::skTCP, @cData ) == nDataLen + cData := HB_Uncompress( nOrigLen, ::Decrypt( cData ) ) + IF .not. Empty( cData ) + ::oResult := HB_Deserialize( cData, nDataLen ) + IF ::oResult != NIL + ::OnFunctionReturn( ::oResult ) + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF + + /* We have a progress */ + CASE cCode == "XHBR33" + IF InetRecvAll( ::skTCP, @cProgress, 10 ) == 10 + nProgress := HB_Deserialize( cProgress, 10 ) + IF nProgress != NIL + lContinue := .T. + ::OnFunctionProgress( nProgress ) + ENDIF + ENDIF + + /* We have a progress with data*/ + CASE cCode == "XHBR34" + IF InetRecvAll( ::skTCP, @cProgress ) == Len( cProgress ) + nProgress := HB_Deserialize( cProgress, Len( cProgress) ) + IF nProgress != NIL .and. InetRecvAll( ::skTCP, @cDataLen ) == Len( cDataLen ) + nDataLen := HB_GetLen8( cDataLen ) + cData := Space( nDataLen ) + IF InetRecvAll( ::skTCP, @cData ) == nDataLen + ::oResult := HB_Deserialize(::Decrypt( cData), nDataLen ) + IF ::oResult != NIL + lContinue := .T. + ::OnFunctionProgress( nProgress, ::oResult ) + ENDIF + ENDIF + ENDIF + ENDIF + + /* We have a progress with compressed data*/ + CASE cCode == "XHBR35" + IF InetRecvAll( ::skTCP, @cProgress ) == Len( cProgress ) + nProgress := HB_Deserialize( cProgress, Len( cProgress ) ) + IF nProgress != NIL .and. InetRecvAll( ::skTCP, @cOrigLen ) == Len( cOrigLen ) + nOrigLen = HB_GetLen8( cOrigLen ) + IF InetRecvAll( ::skTCP, @cDataLen ) == Len( cDataLen ) + nDataLen := HB_GetLen8( cDataLen ) + cData := Space( nDataLen ) + IF InetRecvAll( ::skTCP, @cData ) == nDataLen + cData := HB_Uncompress( nOrigLen, cData ) + IF .not. Empty( cData ) + ::oResult := HB_Deserialize( ::Decrypt( cData), nDataLen ) + IF ::oResult != NIL + lContinue := .T. + ::OnFunctionProgress( nProgress, ::oResult ) + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF + ENDCASE + +RETURN lContinue + +/*********************************** +* Utility functions +************************************/ +METHOD GetFunctionName( xId ) CLASS tRpcClient + LOCAL cData, nPos + + IF ValType( xID ) == "A" + cData := xId[3] + ELSEIF Len( ::aFunctions ) > 0 + cData := ::aFunctions[xId][3] + ELSE + cData := "" + ENDIF + + IF .not. Empty(cData) + nPos := At( "(", cData ) + cData := Substr( cData, 1, nPos-1 ) + ENDIF + +RETURN cData + + +METHOD GetServerName( xId ) CLASS tRpcClient + LOCAL cData + + IF ValType( xID ) == "A" + cData := xId[2] + ELSE + IF Len( ::aFunctions ) > 0 + cData := ::aFunctions[xId][2] + ELSEIF Len( ::aServers ) > 0 + cData := ::aServers[xId][2] + ELSE + cData := "" + ENDIF + ENDIF +RETURN cData + + +METHOD GetServerAddress( xId ) CLASS tRpcClient + LOCAL cData + + IF ValType( xID ) == "A" + cData := xId[1] + ELSE + IF .not. Empty( ::aFunctions ) + cData := ::aFunctions[xId][1] + ELSEIF .not. Empty( ::aServers ) + cData := ::aServers[xId][1] + ELSE + cData := "" + ENDIF + ENDIF + +RETURN cData + + +METHOD Encrypt(cDataIn) CLASS tRPCClient + IF ::bEncrypted + RETURN HB_Crypt( cDataIn, ::cCryptKey ) + ENDIF +RETURN cDataIn + + +METHOD Decrypt(cDataIn) CLASS tRPCClient + IF ::bEncrypted + RETURN HB_Decrypt( cDataIn, ::cCryptKey ) + ENDIF +RETURN cDataIn + + +/*********************************** +* Event handlers +************************************/ + +METHOD OnScanComplete() CLASS tRPCClient + IF ::bOnScanComplete != NIL + RETURN Eval( ::bOnScanComplete ) + ENDIF +RETURN .T. + +METHOD OnScanServersProgress( aLoc ) CLASS tRPCClient + IF ::bOnScanServersProgress != NIL + RETURN Eval( ::bOnScanServersProgress, aLoc ) + ENDIF +RETURN .T. + +METHOD OnScanFunctionsProgress( aLoc ) CLASS tRPCClient + IF ::bOnScanFunctionsProgress != NIL + RETURN Eval( ::bOnScanFunctionsProgress, aLoc ) + ENDIF +RETURN .T. + +METHOD OnFunctionFail( nReason, cReason ) CLASS tRPCClient + IF ::bOnFunctionFail != NIL + RETURN Eval( ::bOnFunctionFail, nReason, cReason ) + ENDIF +RETURN .T. + +METHOD OnFunctionReturn( oReturn ) CLASS tRPCClient + IF ::bOnFunctionReturn != NIL + RETURN Eval( ::bOnFunctionReturn, oReturn ) + ENDIF +RETURN .T. + +METHOD OnFunctionProgress( nProgress, oData ) CLASS tRPCClient + IF ::bOnFunctionProgress != NIL + RETURN Eval( ::bOnFunctionProgress, nProgress, oData ) + ENDIF +RETURN .T. diff --git a/harbour/contrib/xhb/ttable.ch b/harbour/contrib/xhb/ttable.ch new file mode 100644 index 0000000000..b0cdca7900 --- /dev/null +++ b/harbour/contrib/xhb/ttable.ch @@ -0,0 +1,200 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * Header file for Table,Record and Field Class + * + * Copyright 1999 {list of individual authors and e-mail addresses} + * www - http://www.harbour-project.org + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/). + * + * As a special exception, the Harbour Project gives permission for + * additional uses of the text contained in its release of Harbour. + * + * The exception is that, if you link the Harbour libraries with other + * files to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the Harbour library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the Harbour + * Project under the name Harbour. If you copy code from other + * Harbour Project or Free Software Foundation releases into a copy of + * Harbour, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for Harbour, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. + * + */ + +#ifndef _OTABLE_CH_ + +// --> Network messages +#define _NET_USE_FAIL_MSG "Net Open Fail !!!" + + +// --> ::dbMove() constants +#define _DB_TOP -999999999999 +#define _DB_BOTTOM -888888888888 +#define _DB_BOF -777777777777 +#define _DB_EOF -666666666666 +#define NET_RECLOCK 1 +#define NET_FILELOCK 2 +#define NET_APPEND 3 +#define NET_OPEN_MODE .T. +#define EXCLUSIVE_OPEN_MODE .F. +#define RETRY_MSG "NETWORK ERROR;Continue Attempt to Lock Record/File ?" +#define YESNO_COLOR "R/W" +#define MAX_TABLE_AREAS 680 + +#xcommand DEFAULT := ; + [, := ] => ; + := If( == nil, , ) ;; + [ := If( == nil, , ); ] + +#xcommand DEFAULT TO [, TO ] ; + => ; + IF == NIL ; := ; END ; + [; IF == NIL ; := ; END ] + +// --> OOPs +#xtranslate BYNAME [, ] => :: := [; :: := ] +#xtranslate BYNAME DEFAULT => :: := BYDEFAULT , +#xtranslate BYDEFAULT , => if( == NIL, , ) + +#xCommand NETUSE <(cDBF)> ; + [ALIAS ] ; + [VIA ] ; + [TIMER ] ; + [] ; + [] ; + => ; + netDbUse( <(cDBF)>, <(cAlias)>, , , ; + <.new.>, NET_OPEN_MODE, <.ro.> ) + + +// --> new table object +#xCommand DEFINE TABLE ; + [FILE ] ; + [INDEX ] ; + [ALIAS ] ; + [VIA ] ; + [PATH ] ; + [] ; + [] ; + [] ; + =>; + := TableNew( ; + <(cFileDBF)>, ; + <"cAlias">, ; + <(cFileIDX)>, ; + <(cDriver)>, ; + <.lshared.>, ; + <(cPathDBF)>, ; + <.lnew.>, ; + <.lrdonly.> ) + + +// --> new order object +#xCommand DEFINE ORDER [] ; + ON [KEY] ; + [TAG ] ; + [LABEL ] ; + [FOR ] ; + [WHILE ] ; + [EVAL ] ; + [EVERY ] ; + [] ; + [TO ]; + IN ; + =>; + [:=] :AddOrder( ; + <(cTag)>, ; + <"key">, ; + <(cLabel)>, ; + <"for">, ; + <"while">, ; + [<.unique.>], ; + <{eval}>, ; + , ; + <(cOrderFile)>; + ) + + + +#xCommand ADD FIELD DATA [] TO ; + => ; + :ClassAdd( <"cFld">,, {|Self| [] },,) + +#xCommand DEFINE FIELD DATA [] TO ; + => ; + :ClassAdd( <"cFld">,, {|Self| [] },,) + + +// --> ::undo() buffer constants + +#define _WRITE_BUFFER 1 +#define _DELETE_BUFFER 2 +#define _RECALL_BUFFER 3 + + +#xCommand BEGIN TRANSACTION IN => :SetMonitor( .T. ) + +#xCommand ROLLBACK ; + [STEP ] ; + IN ; + => ; + :Undo( , [] ) + +#xCommand END TRANSACTION IN => :SetMonitor( .F. ) + +#command SKIP in => :dbSkip(1) +#command SKIP in => :dbSkip( ) + +#command SEEK ; + [] ; + [] in ; + => :dbSeek( , if( <.soft.>, .T., NIL ), if( <.last.>, .T., NIL ) ) + +#translate CSY_TYPE Character => "C" + +#xtranslate CSY_TYPE Numeric => "N" +#xtranslate CSY_TYPE Date => "D" +#xtranslate CSY_TYPE Memo => "M" +#xtranslate CSY_TYPE Logical => "L" +#xtranslate CSY_TYPE Auto => "A" +#xcommand CREATE DATABASE FILE => :=HBTable():CreateTable(<(file)>);#define _TABLE_ +#xTranslate FIELD [ ] ; + [ NAME <(cName)> ] ; + [ TYPE ] ; + [ LEN ] ; + [ DEC ] ; + OF ; + => ; + [ := ] _TABLE_:AddField( <(cName)>,CSY_TYPE , , ) +#xCommand BUILD TABLE => _TABLE_:Gentable() +#define _OTABLE_CH_ +#endif diff --git a/harbour/contrib/xhb/ttable.prg b/harbour/contrib/xhb/ttable.prg new file mode 100644 index 0000000000..3429ab3bc5 --- /dev/null +++ b/harbour/contrib/xhb/ttable.prg @@ -0,0 +1,1558 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * Table,Record and Field Class + * + * Copyright 2000-2003 Manos Aspradakis maspr@otenet.gr + * www - http://www.harbour-project.org + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/). + * + * As a special exception, the Harbour Project gives permission for + * additional uses of the text contained in its release of Harbour. + * + * The exception is that, if you link the Harbour libraries with other + * files to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the Harbour library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the Harbour + * Project under the name Harbour. If you copy code from other + * Harbour Project or Free Software Foundation releases into a copy of + * Harbour, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for Harbour, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. + * + */ + + /* + * The following parts are Copyright of the individual authors. + * www - http://www.harbour-project.org + * + * + * Copyright 2000 -2002 Luiz Rafael Culik + * Methods CreateTable(),Gentable(),AddField() + * Plus optimization for Xharbour + * + */ + + +#include "hbclass.ch" + +#include "xhb.ch" + +#include "ttable.ch" +#include "set.ch" +#include "ord.ch" +#include "common.ch" +#include "inkey.ch" +#include "dbinfo.ch" +#include "error.ch" +#define COMPILE(c) &("{||" + c + "}") + +//request DBFCDX +STATIC saTables := {} +/* NetWork Functions */ +STATIC snNetDelay := 30 +STATIC slNetOk := .F. +STATIC scNetMsgColor := "GR+/R" + +FUNCTION NetDbUse( cDataBase, cAlias, nSeconds, cDriver, ; + lNew, lOpenMode, lReadOnly ) + LOCAL nKey + LOCAL lForever + LOCAL cOldScreen := SAVESCREEN( MAXROW(), 0, MAXROW(), MAXCOL() + 1 ) + LOCAL lFirstPass := .T. + + DEFAULT cDriver := "DBFCDX" + DEFAULT lNew := .T. + DEFAULT lOpenMode := NET_OPEN_MODE + DEFAULT lReadOnly := .F. + DEFAULT nSeconds := snNetDelay + + slNetOk := .F. + nSeconds *= 1.00 + lforever := ( nSeconds = 0 ) + + KEYBOARD CHR( 255 ) + INKEY() + + DO WHILE ( lforever .or. nSeconds > 0 ) .and. LASTKEY() != K_ESC + IF !lfirstPass + DISPOUTAT( MAXROW(), 0, ; + PADC( "Network retry ³ " + ; + LTRIM( STR( nSeconds, 4, 1 ) ) + " ³ ESCape = Exit ", ; + MAXCOL() + 1 ), ; + scNetMsgColor ) + lFirstPass := .F. + ENDIF + + DBUSEAREA( lNew, ; + ( cDriver ), ( cDatabase ), ( cAlias ), ; + lOpenMode, ; + .F. ) + + IF !NETERR() // USE SUCCEEDS + RESTSCREEN( MAXROW(), 0, MAXROW(), MAXCOL() + 1, cOldScreen ) + slNetOk := .T. + ELSE + lFirstPass := .F. + ENDIF + + IF !slNetOK + nKey := INKEY( .5 ) // WAIT 1 SECOND + nSeconds -= .5 + ELSE + RESTSCREEN( MAXROW(), 0, MAXROW(), MAXCOL() + 1, cOldScreen ) + EXIT + ENDIF + + IF nKey == K_ESC + RESTSCREEN( MAXROW(), 0, MAXROW(), MAXCOL() + 1, cOldScreen ) + EXIT + ENDIF + + ENDDO + + RESTSCREEN( MAXROW(), 0, MAXROW(), MAXCOL() + 1, cOldScreen ) + +RETURN ( slNetOk ) + + +FUNCTION NetLock( nType, lReleaseLocks, nSeconds ) + + LOCAL cSave := SAVESCREEN( MAXROW(), 0, MAXROW(), MAXCOL() + 1 ) + LOCAL lContinue := .T. + LOCAL lSuccess := .F. + LOCAL nWaitTime + LOCAL bOperation + LOCAL xIdentifier + LOCAL nKey + LOCAL nCh + LOCAL cWord + + IF .not. ( VALTYPE( nType ) == "N" ) .or. ; + ( ( .not. ( nType == 1 ) ) .and. ; + ( .not. ( nType == 2 ) ) .and. ; + ( .not. ( nType == 3 ) ) ) + ALERT( "Invalid Argument passed to NETLOCK()" ) + RETURN ( lSuccess ) + ENDIF + + DEFAULT lReleaseLocks := .F. + DEFAULT nSeconds := snNetDelay + + nWaitTime := nSeconds + + SWITCH nType + CASE NET_RECLOCK // 1 = Record Lock... + xIdentifier := IF( lReleaseLocks, NIL, RECNO() ) + bOperation := { | x | DBRLOCK( x ) } + exit + CASE NET_FILELOCK // 2 = File Lock... + bOperation := { || FLOCK() } + exit + CASE NET_APPEND // 3 = Append Blank... + xIdentifier := lReleaseLocks + bOperation := { | x | DBAPPEND( x ), !NETERR() } + exit + END + + slNetOk := .F. + + WHILE lContinue == .T. + + /* + IF (nKey := INKEY()) == K_ESC + RestScreen( maxrow(),0,maxrow(),maxcol()+1, cSave) + EXIT + ENDIF + */ + + WHILE nSeconds > 0 .and. lContinue == .T. + IF EVAL( bOperation, xIdentifier ) + nSeconds := 0 + lSuccess := .T. + lContinue := .F. + slNetOK := .T. + EXIT + ELSE + IF nType == 1 + cWord := "( " + DBINFO( 33 ) + " - Record Lock )" + ELSEIF nType == 1 + cWord := "( " + DBINFO( 33 ) + " - File Lock )" + ELSEIF nType == 3 + cWord := "( " + DBINFO( 33 ) + " - File Append )" + ELSE + cWord := "( " + DBINFO( 33 ) + " - ??? " + ENDIF + + DISPOUTAT( MAXROW(), 0, ; + PADC( "Network Retry " + cWord + " ³ " + STR( nSeconds, 3 ) + " ³ ESC Exit", MAXCOL() + 1 ), ; + scNetMsgColor ) + + nKey := INKEY( 1 ) //TONE( 1,1 ) + nSeconds -- //.5 + IF nKey == K_ESC + RESTSCREEN( MAXROW(), 0, MAXROW(), MAXCOL() + 1, cSave ) + EXIT + ENDIF + ENDIF + ENDDO + + IF LASTKEY() == K_ESC + RESTSCREEN( MAXROW(), 0, MAXROW(), MAXCOL() + 1, cSave ) + EXIT + ENDIF + + IF !lSuccess + nSeconds := nWaitTime + nCh := ALERT( RETRY_MSG, { " YES ", " NO " } ) + + IF nCh == 1 + lContinue := .T. + ELSE + lContinue := .F. + ENDIF + + IF lContinue == .F. + //EXIT + RESTSCREEN( MAXROW(), 0, MAXROW(), MAXCOL() + 1, cSave ) + RETURN ( lSuccess ) + ENDIF + + ENDIF + ENDDO + + RESTSCREEN( MAXROW(), 0, MAXROW(), MAXCOL() + 1, cSave ) + +RETURN ( lSuccess ) + + +FUNCTION NetFunc( bBlock, nSeconds ) + + LOCAL lForever // Retry forever? + + DEFAULT nSeconds := snNetDelay + lForever := ( nSeconds == 0 ) + + // Keep trying as long as specified or default + DO WHILE ( lForever .or. ( nSeconds > 0 ) ) + + IF EVAL( bBlock ) + RETURN ( .T. ) // NOTE + ENDIF + + INKEY( 1 ) // Wait 0.5 seconds + nSeconds -= 0.5 + ENDDO + +RETURN ( .F. ) // Not locked + + +// { DBFName, Alias, { idx Names } } +// Returns: 0 All Ok +// -1 DBF File not found +// -2 DBF File open Error +// -3 Index File open Error + +FUNCTION NetOpenFiles( aFiles ) + + LOCAL nRet := 0 + LOCAL xFile, cIndex + + FOR EACH xFile IN aFiles + + IF !FILE( xFile[ 1 ] ) + nRet := - 1 + EXIT + ENDIF + + IF NetDbUse( xFile[ 1 ], xFile[ 2 ], snNetDelay, "DBFCDX" ) + IF VALTYPE( xFile[ 3 ] ) == "A" + FOR EACH cIndex IN xFile[ 3 ] + IF FILE( cIndex ) + ORDLISTADD( cIndex ) + ELSE + nRet := - 3 + EXIT + ENDIF + NEXT + ENDIF + ELSE + nRet := - 2 + EXIT + ENDIF + NEXT + + RETURN nRet + + +/* NETWORK METHODS */ + +FUNCTION NetDelete() + + slNetOK := .F. + + IF NetLock( NET_RECLOCK ) == .T. + DBDELETE() + slNetOK := .T. + ENDIF + + IF !NETERR() + DBSKIP( 0 ) + DBCOMMIT() + ELSE + slNetOK := .T. + ALERT( " Failed to DELETE Record -> " + STR( RECNO() ) ) + ENDIF +RETURN ( slNetOk ) + + +FUNCTION NetReCall() + + slNetOk := .F. + + IF NetLock( NET_RECLOCK ) == .T. + DBRECALL() + slNetOk := .T. + ENDIF + + IF !NETERR() + DBSKIP( 0 ) + DBCOMMIT() + ELSE + slNetOK := .T. + ALERT( " Failed to RECALL Record -> " + STR( RECNO() ) ) + ENDIF + +RETURN ( slNetOk ) + + +FUNCTION NetRecLock( nSeconds ) + + DEFAULT nSeconds := snNetDelay + + slNetOK := .F. + + IF NetLock( NET_RECLOCK,, nSeconds ) // 1 + slNetOK := .T. + ENDIF + +RETURN ( slNetOK ) + + +FUNCTION NetFileLock( nSeconds ) + + slNetOK := .F. + DEFAULT nSeconds := snNetDelay + + IF NetLock( NET_FILELOCK,, nSeconds ) + slNetOK := .T. + ENDIF + +RETURN ( slNetOK ) + + +FUNCTION NetAppend( nSeconds, lReleaseLocks ) + + LOCAL nOrd + DEFAULT lReleaseLocks := .T. + DEFAULT nSeconds := snNetDelay + slNetOK := .F. + nOrd := ORDSETFOCUS( 0 ) // --> set order to 0 to append ??? + + IF NetLock( NET_APPEND,, nSeconds ) + //DbGoBottom() + slNetOK := .T. + ENDIF + + ORDSETFOCUS( nOrd ) + +RETURN ( slNetOK ) + + +PROCEDURE NetFlush() + + DBCOMMITALL() + DBUNLOCKALL() + DBSKIP( 0 ) +RETURN + + +FUNCTION NetCommitAll() + + LOCAL n + + FOR n := 1 TO MAX_TABLE_AREAS + IF !EMPTY( ALIAS( n ) ) + ( ALIAS( n ) )->( DBCOMMIT(), DBUNLOCK() ) + ENDIF + NEXT + +RETURN n + + +FUNCTION IsLocked( nRecId ) +default nRecID to recno() + +RETURN ( ASCAN( DBRLOCKLIST(), { | n | n == nRecID } ) > 0 ) + + +FUNCTION NetError() +RETURN !slNetOK + + +FUNCTION SetNetDelay( nSecs ) + + LOCAL nTemp := snNetDelay + IF nSecs != NIL + snNetDelay := nSecs + ENDIF +RETURN ( nTemp ) + + +FUNCTION SetNetMsgColor( cColor ) + + LOCAL cTemp := scNetMsgColor + IF cColor != NIL + scNetmsgColor := cColor + ENDIF +RETURN ( cTemp ) + + +/**** +* Utility functions +* +* TableNew() +* +* getTable() +*/ + +FUNCTION TableNew( cDBF, cALIAS, cOrderBag, cDRIVER, ; + lNET, cPATH, lNEW, lREADONLY ) + LOCAL nPos + LOCAL lAuto + LOCAL oDB + LOCAL o + DEFAULT lNET TO .T. + DEFAULT lNEW TO .T. + DEFAULT lREADONLY TO .F. + DEFAULT cDRIVER TO "DBFCDX" + DEFAULT cPATH TO SET( _SET_DEFAULT ) + DEFAULT cAlias TO FixExt( cDbf ) + DEFAULT cOrderBag TO FixExt( cDbf ) //+".CDX" + + lAuto := SET( _SET_AUTOPEN, .F. ) + + IF ( nPos := ASCAN( saTables, { | e | e[ 1 ] == UPPER( cALIAS ) } ) ) > 0 + + oDB := saTables[ nPos, 2 ] + + ELSE + o := HBTable():New( cDBF, cALIAS, cOrderBag, cDRIVER, ; + lNET, cPATH, lNEW, lREADONLY ) + IF o:Open() + oDB := o:FldInit() + ENDIF + + AADD( saTables, { UPPER( cAlias ), oDB } ) + + ENDIF + + SET( _SET_AUTOPEN, lAuto ) + +RETURN oDB + + +FUNCTION GetTable( cAlias ) + + LOCAL nPos + LOCAL oDB + IF ( nPos := ASCAN( saTables, { | e | e[ 1 ] == UPPER( cALIAS ) } ) ) > 0 + oDB := saTables[ nPos, 2 ] + ENDIF +RETURN oDB + + +/**** +* +* CLASS HBField() +* +* +* +*/ + +CLASS HBField + + DATA Alias INIT ALIAS() + DATA Name INIT "" + DATA Type INIT "C" + DATA Len INIT 0 + DATA Dec INIT 0 + DATA order INIT 0 + DATA Value + + METHOD GET() INLINE ::value := ( ::alias )->( FIELDGET( ::order ) ) + METHOD Put( x ) INLINE ::value := x ,; + ( ::alias )->( FIELDPUT( ::order, x ) ) + +ENDCLASS + +/**** +* +* CLASS HBRecord() +* +* +* +*/ + +CLASS HBRecord + + DATA Buffer INIT {} + DATA Alias INIT ALIAS() + DATA Number INIT 0 + DATA aFields INIT {} + + METHOD New() + METHOD GET() + METHOD Put() + +ENDCLASS + + +METHOD NEW( cAlias ) CLASS HBRecord + + LOCAL i + LOCAL oFld + LOCAL aStruc + LOCAL aItem + + DEFAULT cAlias TO ALIAS() + + ::Alias := cAlias + ::Buffer := {} + ::aFields := ARRAY( ( ::alias )->( FCOUNT() ) ) + + aStruc := ( ::alias )->( DBSTRUCT() ) + + FOR EACH aItem in ::aFields + i := HB_EnumIndex() + oFld := HBField() + oFld:order := i + oFld:Name := ( ::alias )->( FIELDNAME( i ) ) + oFld:Type := aStruc[ i, 2 ] + oFld:LEN := aStruc[ i, 3 ] + oFld:Dec := aStruc[ i, 4 ] + oFld:Alias := ::alias + aItem := oFld + NEXT + +RETURN Self + + +PROCEDURE GET() CLASS HBRecord + + LOCAL xField + + FOR EACH xField IN ::aFields + xField:GET() + ::buffer[ HB_EnumIndex() ] := xField:value + NEXT + +RETURN + + +PROCEDURE Put() CLASS HBRecord + + LOCAL xField + + FOR EACH xField IN ::aFields + IF xField:Value <> ::buffer[ HB_EnumIndex() ] + xField:PUT( ::buffer[ HB_EnumIndex() ] ) + ::buffer[ HB_EnumIndex() ] := xField:value + ENDIF + NEXT + +RETURN + +/**** +* +* CLASS HBTable +* +* +* +*/ + + //METHOD SetFocus() INLINE (::Alias)->(Select( ::Area )) + // + // + //encapsulated methods + // + // + //Methods + // + // + //table movement + // + // + //RELATION + // + // + //ORDER Management + // +CLASS HBTable + + DATA Buffer INIT {} // 1 + DATA Alias INIT ALIAS() // 2 + DATA Area INIT 0 // 3 + + DATA oRec + DATA aStruc INIT {} + DATA nRecno INIT 0 + DATA cDBF INIT "" + DATA cOrderBag INIT "" + DATA cOrderFile INIT "" + DATA cPATH INIT "" + DATA Driver INIT "DBFCDX" + DATA IsNew INIT .T. + DATA IsReadOnly INIT .F. + DATA IsNet INIT .T. + DATA aSaveState INIT {} + DATA lMonitor INIT .F. + DATA ReadBuffers INIT {} + DATA WriteBuffers INIT {} + DATA DeleteBuffers INIT {} + DATA nDataOffset INIT 0 + DATA BlankBuffer INIT {} + DATA aOrders INIT {} + DATA aChildren INIT {} + DATA oParent + + METHOD EOF() INLINE ( ::Alias )->( EOF() ) + METHOD BOF() INLINE ( ::Alias )->( BOF() ) + METHOD RECNO() INLINE ( ::Alias )->( RECNO() ) + METHOD LASTREC() INLINE ( ::Alias )->( LASTREC() ) + METHOD SKIP( n ) INLINE ( ::Alias )->( DBSKIP( n ) ),; + ::nRecno := ( ::Alias )->( RECNO() ) + + METHOD GOTO( n ) INLINE ( ::Alias )->( DBGOTO( n ) ) + METHOD goTop() INLINE ( ::Alias )->( DBGOTOP() ) + METHOD goBottom() INLINE ( ::Alias )->( DBGOBOTTOM() ) + METHOD SetFocus() INLINE ( ::Alias )->( SELECT( ::ALias ) ) + METHOD Append( l ) INLINE IF( ::isNet, ( ::Alias )->( NetAppend( l ) ), ; + ( ::alias )->( DBAPPEND() ) ) + METHOD RECALL( ) INLINE ( ::Alias )->( NetRecall( ) ) + + METHOD LOCATE( bFor, bWhile, nNext, nRec, lRest ) INLINE ; + ( ::Alias )->( __dbLocate( bFor, bWhile, ; + nNext, nRec, lRest ) ) + METHOD CONTINUE() INLINE ( ::Alias )->( __dbContinue() ) + METHOD FOUND() INLINE ( ::Alias )->( FOUND() ) + METHOD Kill() INLINE ( ::Alias )->( DBCOMMIT() ),; + ( ::Alias )->( DBUNLOCK() ) ,; + ( ::Alias )->( DBCLOSEAREA() ),; + ::ClearBuffers() + METHOD ClearBuffers() INLINE ::ReadBuffers := {},; + ::WriteBuffers := {},; + ::DeleteBuffers := {} + + METHOD dbIsShared() INLINE ( ::Alias )->( DBINFO( DBI_SHARED ) ) + + METHOD dbIsFLocked( ) INLINE ( ::Alias )->( DBINFO( DBI_ISFLOCK ) ) + + METHOD dbLockCount() INLINE ( ::Alias )->( DBINFO( DBI_LOCKCOUNT ) ) + + METHOD DBINFO( n, x ) INLINE ( ::Alias )->( DBINFO( n, x ) ) + + METHOD dbGetAlias() INLINE ( ::Alias ) + + METHOD dbFullPath() INLINE ( ::Alias )->( DBINFO( DBI_FULLPATH ) ) + + METHOD IsRLocked( n ) INLINE ( ::Alias )->( DBRECORDINFO( DBRI_LOCKED, n ) ) + + METHOD IsRUpdated( n ) INLINE ( ::Alias )->( DBRECORDINFO( DBRI_UPDATED, n ) ) + + METHOD DBRECORDINFO( n, x ) INLINE ( ::Alias )->( DBRECORDINFO( n,, x ) ) + + METHOD DBORDERINFO( n, x, u ) INLINE ( ::Alias )->( DBORDERINFO( n, ::cOrderFile, x, u ) ) + + METHOD OrderCount() INLINE ; + ( ::Alias )->( DBORDERINFO( DBOI_ORDERCOUNT, ::cOrderFile ) ) + + METHOD AutoOpen( l ) INLINE ; + ( ::Alias )->( DBORDERINFO( DBOI_AUTOOPEN, ::cOrderFile,, l ) ) + + METHOD AutoShare( l ) INLINE ; + ( ::Alias )->( DBORDERINFO( DBOI_AUTOSHARE, ::cOrderFile,, l ) ) + + METHOD USED() INLINE SELECT( ::Alias ) > 0 + + METHOD ORDSETFOCUS( ncTag ) INLINE ( ::Alias )->( ORDSETFOCUS( ncTag ) ) + METHOD ORDNAME( nOrder ) INLINE ; + ( ::Alias )->( ORDNAME( nOrder, ::cOrderBag ) ) ; + + METHOD ORDNUMBER( cOrder ) INLINE ; + ( ::Alias )->( ORDNUMBER( cOrder, ::cOrderBag ) ) ; + + METHOD ORDSCOPE( n, u ) INLINE ( ::Alias )->( ORDSCOPE( n, u ) ) + + METHOD ORDISUNIQUE( nc ) INLINE ( ::Alias )->( ORDISUNIQUE( nc, ; + ::cOrderBag ) ) ; + + METHOD ORDSKIPUNIQUE( n ) INLINE ( ::Alias )->( ORDSKIPUNIQUE( n ) ) + METHOD ORDSETRELATION( n, b, c ) INLINE ( ::Alias )->( ORDSETRELATION( n, b, c ) ) + + METHOD SetTopScope( xScope ) INLINE ; + ( ::alias )->( ORDSCOPE( TOPSCOPE, xScope ) ) + METHOD SetBottomScope( xScope ) INLINE ; + ( ::alias )->( ORDSCOPE( BOTTOMSCOPE, xScope ) ) + METHOD KillScope() INLINE ( ::alias )->( ORDSCOPE( TOPSCOPE, NIL ) ) ,; + ( ::alias )->( ORDSCOPE( BOTTOMSCOPE, NIL ) ) + + METHOD New( cDBF, cALIAS, cOrderBag, cDRIVER, ; + lNET, cPATH, lNEW, lREADONLY ) + + METHOD OPEN() + + METHOD dbMove( n ) + METHOD FldInit() + METHOD READ( l ) + METHOD ReadBLANK( l ) + METHOD Write( l ) + METHOD BufWrite( l ) + MESSAGE DELETE() METHOD __oTDelete() // reserved word - *HAS* to be renamed... + METHOD SetMonitor( l ) + METHOD Undo( a, b, c ) + + METHOD DBSKIP( n ) INLINE ( ::Alias )->( DBSKIP( n ) ),; + ::nRecno := ( ::alias )->( RECNO() ) + + METHOD DBGOTO( n ) INLINE ( ::Alias )->( DBGOTO( n ) ) + + METHOD DBEVAL( a, b, c, d, e, f ) INLINE ( ::Alias )->( DBEVAL( a, b, c, d, e, f ) ) + METHOD DBSEEK( a, b, c ) INLINE ( ::Alias )->( DBSEEK( a, b, c ) ) + + + + + METHOD DBFILTER() INLINE ( ::Alias )->( DBFILTER() ) + METHOD SetFilter( c ) INLINE ; + IF( c != NIL, ( ::Alias )->( DBSETFILTER( COMPILE( c ), c ) ), ; + ( ::Alias )->( DBCLEARFILTER() ) ) + + METHOD AddChild( oChild, cKey ) + + METHOD AddOrder( cTag, cKey, cLabel, ; + cFor, cWhile, ; + lUnique, ; + bEval, nInterval, cOrderFile ) + METHOD GetOrderLabels() + METHOD SetOrder( xTag ) + METHOD GetOrder( xOrder ) + METHOD FastReindex() + METHOD REINDEX() + METHOD CreateTable( cFile ) + METHOD AddField( f, t, l, d ) + METHOD Gentable() + + ERROR HANDLER OnError() + +ENDCLASS + + + //--------------------- + // Constructor... + //--------------------- + +METHOD New( cDBF, cALIAS, cOrderBag, cDRIVER, ; + lNET, cPATH, lNEW, lREADONLY ) CLASS HBTable + Local cOldRdd + DEFAULT lNET TO .F. + DEFAULT lNEW TO .T. + DEFAULT lREADONLY TO .F. + DEFAULT cDRIVER TO "DBFCDX" + DEFAULT cPATH TO SET( _SET_DEFAULT ) + DEFAULT cAlias TO FixExt( cDbf ) + DEFAULT cOrderBag TO FixExt( cDbf ) //+".CDX" + + + ::IsNew := lNEW + ::IsNet := lNET + ::IsReadOnly := lREADONLY + ::cDBF := cDBF + ::cPath := cPATH + ::cOrderBag := FixExt( cOrderBag ) + cOldRdd := rddsetdefault( ::driver ) + + ::cOrderFile := ::cOrderBag + ORDBAGEXT() //".CDX" + rddsetdefault( cOldRdd ) + ::Driver := cDRIVER + ::aOrders := {} + ::Area := 0 + ::Alias := cALIAS + ::nDataOffset := LEN( self ) //66 + +RETURN Self + + +METHOD OPEN() CLASS HBTable + + LOCAL lSuccess := .T. + + DBUSEAREA( ::IsNew, ::Driver, ::cDBF, ::Alias, ::IsNET, ::IsREADONLY ) + + IF ::IsNET == .T. + IF NETERR() + ALERT( _NET_USE_FAIL_MSG ) + lSuccess := .F. + RETURN ( lSuccess ) + ENDIF + ENDIF + + SELECT( ::Alias ) + ::Area := SELECT() + IF ::cOrderBag != NIL .and. FILE( ::cPath + ::cOrderFile ) + + SET INDEX TO ( ::cPath + ::cOrderBag ) + ( ::Alias )->( ORDSETFOCUS( 1 ) ) + + ENDIF + + ::Buffer := ARRAY( ( ::Alias )->( FCOUNT() ) ) + ::aStruc := ( ::Alias )->( DBSTRUCT() ) + + ::dbMove( _DB_TOP ) + +RETURN ( lSuccess ) + + +PROCEDURE DBMove( nDirection ) CLASS HBTable + + DEFAULT nDirection TO 0 + + DO CASE + CASE nDirection == 0 + ( ::Alias )->( DBSKIP( 0 ) ) + CASE nDirection == _DB_TOP + ( ::Alias )->( DBGOTOP() ) + CASE nDirection == _DB_BOTTOM + ( ::Alias )->( DBGOBOTTOM() ) + CASE nDirection == _DB_BOF + ( ::Alias )->( DBGOTOP() ) + ( ::Alias )->( DBSKIP( - 1 ) ) + CASE nDirection == _DB_EOF + ( ::Alias )->( DBGOBOTTOM() ) + ( ::Alias )->( DBSKIP( 1 ) ) + OTHERWISE + ( ::Alias )->( DBGOTO( nDirection ) ) + ENDCASE + +RETURN + +// --> +// --> +// --> Insert field definitions and generate virtual child class... +// --> +// --> + +METHOD FldInit() CLASS HBTable + + LOCAL i + LOCAL aDb + LOCAL oNew + LOCAL nScope := 1 + + ::nDataOffset := LEN( self ) - 1 + + ::Buffer := ARRAY( ( ::Alias )->( FCOUNT() ) ) + IF EMPTY( ::Buffer ) + ::Read() + ENDIF + + // --> create new oObject class from this one... + + adb := hbclass():new( ::alias, { "hbtable" } ) + + FOR i := 1 TO FCOUNT() + adb:AddData( ( ::Alias )->( FIELDNAME( i ) ),,, nScope ) + NEXT + + aDB:create() + + oNew := adb:Instance() + + oNew:IsNew := ::IsNew + oNew:IsNet := ::IsNet + oNew:IsReadOnly := ::IsReadOnly + oNew:cDBF := ::cDBF + oNew:cPath := ::cPath + oNew:cOrderBag := ::cOrderBag + oNew:cOrderFile := ::cOrderFile + oNew:Driver := ::Driver + oNew:Area := ::Area + oNew:Alias := ::Alias + oNew:aStruc := ::aStruc + oNew:BlankBuffer := ::BlankBuffer + oNew:aOrders := ::aOrders + oNew:oParent := ::oParent + oNew:Buffer := ::buffer + + SELECT( oNew:Alias ) + + oNew:Area := SELECT() + + oNew:Read() + + IF oNew:cOrderBag != NIL .and. FILE( oNew:cPath + oNew:cOrderFile ) + SET INDEX TO ( oNew:cPath + oNew:cOrderBag ) + ( oNew:Alias )->( ORDSETFOCUS( 1 ) ) + ENDIF + + oNew:buffer := ARRAY( ( oNew:alias )->( FCOUNT() ) ) + oNew:aStruc := ( oNew:alias )->( DBSTRUCT() ) + + IF oNew:Used() + oNew:dbMove( _DB_TOP ) + oNew:Read() + ENDIF + +RETURN oNew + + +PROCEDURE READ( lKeepBuffer ) CLASS HBTable + + LOCAL i + LOCAL nSel := SELECT( ::Alias ) + LOCAL adata := ARRAY( 1, 2 ) + LOCAL Buffer + DEFAULT lKeepBuffer TO .F. + + //? len( ::Buffer ) + + FOR Each Buffer in ::Buffer + + i := HB_EnumIndex() + Buffer := ( ::Alias )->( FIELDGET( i ) ) + + adata[ 1, 1 ] := ( ::Alias )->( FIELDNAME( i ) ) + adata[ 1, 2 ] := ( ::Alias )->( FIELDGET( i ) ) + __ObjSetValueList( Self, aData ) + + NEXT + + IF ( lKeepBuffer == .T. ) .or. ( ::lMonitor == .T. ) + AADD( ::ReadBuffers, { ( ::Alias )->( RECNO() ), ::Buffer } ) + ENDIF + + SELECT( nSel ) + +RETURN + + +PROCEDURE ReadBlank( lKeepBuffer ) CLASS HBTable + + LOCAL i + LOCAL nSel := SELECT( ::Alias ) + LOCAL nRec := ( ::Alias )->( RECNO() ) + LOCAL adata := ARRAY( 1, 2 ) + LOCAL Buffer + DEFAULT lKeepBuffer TO .F. + + ( ::Alias )->( DBGOBOTTOM() ) + ( ::Alias )->( DBSKIP( 1 ) ) // go EOF + + FOR each Buffer in ::Buffer + i := HB_EnumIndex() + Buffer := ( ::Alias )->( FIELDGET( i ) ) + + adata[ 1, 1 ] := ( ::Alias )->( FIELDNAME( i ) ) + adata[ 1, 2 ] := ( ::Alias )->( FIELDGET( i ) ) + __ObjSetValueList( Self, aData ) + + NEXT + + IF ( lKeepBuffer == .T. ) .or. ( ::lMonitor == .T. ) + AADD( ::ReadBuffers, { ( ::Alias )->( RECNO() ), ::Buffer } ) + ENDIF + + ( ::Alias )->( DBGOTO( nRec ) ) + SELECT( nSel ) + +RETURN + + +METHOD Write( lKeepBuffer ) CLASS HBTable + + LOCAL i + LOCAL aOldBuffer := ARRAY( ( ::Alias )->( FCOUNT() ) ) + LOCAL nSel := SELECT( ::Alias ) + LOCAL nOrd := ( ::Alias )->( ORDSETFOCUS() ) + LOCAL aData := __objGetValueList( Self ) + LOCAL xBuffer + LOCAL n + + DEFAULT lKeepBuffer TO .F. + + IF ( lKeepBuffer == .T. ) .or. ( ::lMonitor == .T. ) + + // --> save old record in temp buffer + FOR EACH xBuffer IN aOldBuffer + xBuffer := ( ::Alias )->( FIELDGET( HB_EnumIndex() ) ) + NEXT + + AADD( ::WriteBuffers, { ( ::Alias )->( RECNO() ), aOldBuffer } ) + + ENDIF + + IF ::isNet + IF !( ::Alias )->( NetRecLock() ) + RETURN .F. + ENDIF + ENDIF + + ( ::Alias )->( ORDSETFOCUS( 0 ) ) + + FOR i := 1 TO ( ::Alias )->( FCOUNT() ) + n := ASCAN( adata, { | a | a[ 1 ] == ( ::Alias )->( FIELDNAME( i ) ) } ) + ( ::Alias )->( FIELDPUT( i, adata[ n, 2 ] ) ) + NEXT + + ( ::Alias )->( DBSKIP( 0 ) ) // same as commit + IF ::isNet + ( ::Alias )->( DBRUNLOCK() ) + ENDIF + ( ::Alias )->( ORDSETFOCUS( nOrd ) ) + SELECT( nSel ) + +RETURN ( .T. ) + + +METHOD BUFWrite( aBuffer ) CLASS HBTable + + LOCAL nSel := SELECT( ::Alias ) + LOCAL nOrd := ( ::Alias )->( ORDSETFOCUS() ) + LOCAL Buffer + DEFAULT aBuffer TO ::Buffer + + IF ::isNet + IF !( ::Alias )->( NetRecLock() ) + RETURN .F. + ENDIF + ENDIF + + ( ::Alias )->( ORDSETFOCUS( 0 ) ) + + FOR each Buffer in aBuffer + ( ::Alias )->( FIELDPUT( HB_EnumIndex(), Buffer ) ) + NEXT + + ( ::Alias )->( DBSKIP( 0 ) ) + IF ::isNet + ( ::Alias )->( DBRUNLOCK() ) + ENDIF + ( ::Alias )->( ORDSETFOCUS( nOrd ) ) + SELECT( nSel ) + +RETURN ( .T. ) + + +METHOD __oTDelete( lKeepBuffer ) // ::Delete() + + LOCAL lRet + LOCAL lDeleted := SET( _SET_DELETED, .F. ) // make deleted records visible + // temporarily... + DEFAULT lKeepBuffer TO .F. + + ::Read() + + IF ::isNet + lRet := IF( ( ::Alias )->( NetDelete() ), .T., .F. ) + ELSE + ( ::alias )->( DBDELETE() ) ; lRet := .T. + ENDIF + + IF ( ( lKeepBuffer == .T. ) .or. ( ::lMonitor == .T. ) ) .and. ; + ( lRet == .T. ) + AADD( ::DeleteBuffers, { ( ::Alias )->( RECNO() ), ::Buffer } ) + ENDIF + + IF ::isNet + ( ::Alias )->( DBUNLOCK() ) + ENDIF + + SET( _SET_DELETED, lDeleted ) + +RETURN ( lRet ) + + +METHOD SetMonitor( l ) CLASS HBTable + + LOCAL lTemp := ::lMonitor + ::lMonitor := !( l ) +RETURN lTemp + +// +// Transaction control subsystem... +// + +METHOD Undo( nBuffer, nLevel ) CLASS HBTable + + + LOCAL nLen + LOCAL lRet := .F. + LOCAL lDelState := SET( _SET_DELETED ) + LOCAL nRec :=::RECNO() + LOCAL aBuffers + + DEFAULT nBuffer TO _WRITE_BUFFER + + IF nLevel == NIL + nLevel := 0 + ENDIF + + SWITCH nBuffer + + CASE _DELETE_BUFFER + + IF !EMPTY( ::DeleteBuffers ) + + SET( _SET_DELETED, .F. ) // make deleted records visible temporarily... + + nLen := LEN( ::deleteBuffers ) + + DEFAULT nLevel TO nLen + + IF nLevel == 0 .OR. nLevel == nLen // DO ALL... + FOR EACH aBuffers IN ::deleteBuffers + + ( ::Alias )->( DBGOTO( aBuffers[ 1 ] ) ) + + IF ( ::Alias )->( NetRecall() ) + lRet := .T. + ELSE + lRet := .F. + ENDIF + + NEXT + + IF lRet + ::deleteBuffers := {} + ENDIF + + ELSE // DO CONTROLLED... + + FOR EACH aBuffers IN ::deleteBuffers + IF HB_EnumIndex() > ( nLen - nLevel ) + + ( ::Alias )->( DBGOTO( aBuffers[ 1 ] ) ) + + IF ( ::Alias )->( NetRecall() ) + lRet := .T. + ELSE + lRet := .F. + ENDIF + ENDIF + NEXT + + IF lRet + ASIZE( ::deleteBuffers, ( nLen - nLevel ) ) + ENDIF + + ENDIF + + SET( _SET_DELETED, lDelState ) + + ENDIF + + CASE _WRITE_BUFFER + IF !EMPTY( ::WriteBuffers ) + + nLen := LEN( ::WriteBuffers ) + DEFAULT nLevel TO nLen + + IF nLevel == 0 .OR. nLen == nLevel // Do All... + + FOR EACH aBuffers IN ::writeBuffers + + ( ::Alias )->( DBGOTO( aBuffers[ 1 ] ) ) + + IF ::BufWrite( aBuffers[ 2 ] ) + lRet := .T. + ELSE + ALERT( "Rollback Failed..." ) + lRet := .F. + ENDIF + NEXT + + IF lRet + // erase entries + ::WriteBuffers := {} + ENDIF + + ELSE // do controlled... + + FOR EACH aBuffers IN ::writeBuffers + IF HB_EnumIndex() > ( nLen - nLevel ) + + ( ::Alias )->( DBGOTO( aBuffers[ 1 ] ) ) + + IF ::BufWrite( aBuffers[ 2 ] ) + lRet := .T. + ELSE + ALERT( "Rollback Failed..." ) + lRet := .F. + ENDIF + ENDIF + NEXT + + // erase entries + IF lRet == .t. + ASIZE( ::WriteBuffers, ( nLen - nLevel ) ) + ENDIF + + ENDIF + + ENDIF + + DEFAULT + + END + + ( ::Alias )->( DBUNLOCK() ) + ( ::Alias )->( DBGOTO( nRec ) ) + ::Read() + +RETURN ( lRet ) + + +// +// ORDER MANAGEMENT +// + +METHOD AddOrder( cTag, cKey, cLabel, ; + cFor, cWhile, ; + lUnique, ; + bEval, nInterval, cOrderFile ) CLASS HBTable + LOCAL oOrd + DEFAULT cOrderFile TO ::cOrderBag + + oOrd := HBOrder():New( cTag, cKey, cLabel, ; + cFor, cWhile, ; + lUnique, ; + bEval, nInterval ) + + oOrd:oTable := Self + oOrd:cOrderBag := ::cOrderBag + + AADD( ::aOrders, oOrd ) + +RETURN oOrd + + +METHOD Reindex() CLASS HBTable + + + LOCAL nSel := SELECT( ::Alias ) + LOCAL nOrd := ( ::Alias )->( ORDSETFOCUS( 0 ) ) + + IF LEN( ::aOrders ) > 0 + + IF ::USED() + ::Kill() + ENDIF + + ::Isnet := .F. + + IF FILE( ::cPath + ::cOrderFile ) + IF FERASE( ::cPath + ::cOrderFile ) != 0 + // --> ALERT(".CDX *NOT* Deleted !!!" ) + ENDIF + ENDIF + + IF !::Open() + RETURN .F. + ENDIF + + AEVAL( ::aOrders, { | o | o:Create() } ) + + ::Kill() + ::IsNet := .T. + + IF !::Open() + RETURN .F. + ENDIF + + ENDIF + + ( ::Alias )->( DBSETINDEX( ::cOrderBag ) ) + ( ::Alias )->( ORDSETFOCUS( nOrd ) ) + ( ::Alias )->( DBGOTOP() ) + ( ::Alias )->( DBUNLOCK() ) + SELECT( nSel ) + +RETURN .T. + + +METHOD FastReindex() CLASS HBTable + + + LOCAL nSel := SELECT( ::Alias ) + LOCAL nOrd := ( ::Alias )->( ORDSETFOCUS( 0 ) ) + + IF LEN( ::aOrders ) > 0 + + ::Kill() + + ::Isnet := .F. + IF FILE( ::cPath + ::cOrderFile ) + IF FERASE( ::cPath + ::cOrderFile ) != 0 + // --> ALERT(".CDX *NOT* Deleted !!!" ) + ENDIF + ENDIF + + IF !::Open() + RETURN .F. + ENDIF + + ( ::Alias )->( ORDLISTREBUILD() ) + + ::Kill() + ::IsNet := .T. + + IF !::Open() + RETURN .F. + ENDIF + + ENDIF + + ( ::Alias )->( DBSETINDEX( ::cOrderBag ) ) + ( ::Alias )->( ORDSETFOCUS( nOrd ) ) + ( ::Alias )->( DBGOTOP() ) + ( ::Alias )->( DBUNLOCK() ) + SELECT( nSel ) + +RETURN .T. + + +METHOD GetOrder( xOrder ) CLASS HBTable + + LOCAL nPos + LOCAL xType := VALTYPE( xOrder ) + + IF xType == "C" + nPos := ASCAN( ::aOrders, { | e | e:Tag == xOrder } ) + ELSEIF xType == "N" .and. xOrder > 0 + nPos := xOrder + ELSE + nPos := 0 + ENDIF + + IF nPos == 0 + nPos := 1 + ENDIF + +RETURN ::aOrders[ nPos ] // returns oOrder + + +METHOD SetOrder( xTag ) CLASS HBTable + + LOCAL xType := VALTYPE( xTag ) + LOCAL nOldOrd := ( ::Alias )->( ORDSETFOCUS() ) + + SWITCH xType + CASE "C" // we have an Order-TAG + ( ::Alias )->( ORDSETFOCUS( xTag ) ) + EXIT + CASE "N" // we have an Order-Number + IF xTag <= 0 + ( ::Alias )->( ORDSETFOCUS( 0 ) ) + ELSE + ::Getorder( xTag ):SetFocus() + ENDIF + EXIT + CASE "O" // we have an Order-Object + xTag:SetFocus() + EXIT + DEFAULT + ( ::Alias )->( ORDSETFOCUS( 0 ) ) + END +RETURN nOldOrd + + +METHOD GetOrderLabels() CLASS HBTable + + LOCAL aRet := {} + IF !EMPTY( ::aOrders ) + AEVAL( ::aOrders, { | e | AADD( aRet, e:Label ) } ) + ENDIF +RETURN aRet + +// +// Relation Methods +// + +PROCEDURE AddChild( oChild, cKey ) CLASS HBTable // ::addChild() + + AADD( ::aChildren, { oChild, cKey } ) + oChild:oParent := Self + ( ::Alias )->( ORDSETRELATION( oChild:Alias, COMPILE( cKey ), cKey ) ) +RETURN + +/**** +* FixExt( cFileName ) +* extract .CDX filename from .DBF filename +*/ + +STATIC FUNCTION FixExt( cFileName ) + + LOCAL nLeft := AT( ".", cFilename ) +RETURN ( LEFT( cFileName, IF( nLeft == 0, ; + LEN( cFilename ), ; + nLeft - 1 ) ) ) + + +METHOD CreateTable( cFile ) CLASS HBTable + + ::cDbf := cFile + IF LEN( ::aStruc ) > 0 + ::aStruc := {} + ::aOrders := {} + ENDIF +RETURN Self + + +PROCEDURE AddField( f, t, l, d ) CLASS HBTable + + AADD( ::aStruc, { f, t, l, d } ) +RETURN + + +PROCEDURE Gentable() CLASS HBTable + + DBCREATE( ::cDbf, ::aStruc, ::Driver ) +RETURN + + +METHOD OnError( uParam ) CLASS HBTable + + LOCAL cMsg := __GetMessage() + LOCAL nPos + LOCAL uRet, oErr + + if uParam <> nil .and. LEFT( cMsg, 1 ) == '_' + cMsg := SubStr( cMsg, 2 ) + endif + nPos := (::Alias)->( FieldPos(cMsg) ) + + if nPos <> 0 + uRet := (::Alias)->( if(uParam == nil, FieldGet(nPos), FieldPut(nPos, uParam)) ) + else + + oErr := ErrorNew() + oErr:Args := { Self, cMsg, uParam } + oErr:CanDefault := .F. + oErr:CanRetry := .F. + oErr:CanSubstitute := .T. + oErr:Description := "Invalid class member" + oErr:GenCode := EG_NOVARMETHOD + oErr:Operation := "HBTable:" + cMsg + oErr:Severity := ES_ERROR + oErr:SubCode := -1 + oErr:SubSystem := "HBTable" + uRet := Eval( ErrorBlock(), oErr ) + + endif + + RETURN uRet + + +CLASS HBOrder + + DATA oTable + DATA cOrderBag + DATA Label, TAG + DATA cKey, bKey + DATA cFor, bFor + DATA cWhile, bWhile + DATA Unique INIT .F. + DATA bEval + DATA nInterval + METHOD ALIAS() INLINE ::oTable:Alias + + METHOD New( cTag, cKey, cLabel, cFor, cWhile, lUnique, bEval, nInterval, cOrderBag ) + METHOD Create() + + METHOD SetFocus() INLINE ( ::alias )->( ORDSETFOCUS( ::Tag, ::cOrderBag ) ) + METHOD Destroy() INLINE ( ::alias )->( ORDDESTROY( ::Tag, ::cOrderBag ) ) + METHOD ORDDESTROY() INLINE ( ::alias )->( ORDDESTROY( ::Tag, ::cOrderBag ) ) + METHOD ORDBAGEXT() INLINE ( ::alias )->( ORDBAGEXT() ) + METHOD ORDKEYCOUNT() INLINE ( ::alias )->( ORDKEYCOUNT( ::Tag, ::cOrderBag ) ) + METHOD ORDFOR() INLINE ( ::alias )->( ORDFOR( ::Tag, ::cOrderBag ) ) + METHOD ORDISUNIQUE() INLINE ( ::alias )->( ORDISUNIQUE( ::Tag, ::cOrderBag ) ) + METHOD ORDKEY() INLINE ( ::alias )->( ORDKEY( ::Tag, ::cOrderBag ) ) + METHOD ORDKEYNO() INLINE ( ::alias )->( ORDKEYNO( ::Tag, ::cOrderBag ) ) + METHOD ORDKEYVAL() INLINE ( ::alias )->( ORDKEYVAL( ::Tag, ::cOrderBag ) ) + +ENDCLASS + +METHOD New( cTag, cKey, cLabel, cFor, cWhile, lUnique, bEval, nInterval, cOrderBag ) CLASS HBOrder + + DEFAULT cKey TO ".T." + DEFAULT lUnique TO .F. + DEFAULT cFor TO ".T." + DEFAULT cWhile TO ".T." + DEFAULT bEval TO { || .T. } + DEFAULT nInterval TO 1 + DEFAULT cLabel TO cTag + ::cOrderBag := cOrderBag + ::Tag := cTag + ::cKey := cKey + ::cFor := cFor + ::cWhile := cWhile + ::bKey := COMPILE( cKey ) + ::bFor := COMPILE( cFor ) + ::bWhile := COMPILE( cWhile ) + ::bEval := bEval + ::nInterval := nInterval + ::Label := cLabel +RETURN Self + + +PROCEDURE Create() CLASS HBOrder + + DEFAULT ::cOrderBag TO ::oTable:cOrderBag + //? "<<<",::alias, ::cOrderBag + ( ::alias )->( ORDCONDSET( ::cFor, ::bFor, ; + .T., ; + ::bWhile, ; + ::bEval, ::nInterval ) ) + + ( ::alias )->( ORDCREATE( ::cOrderBag, ::Tag, ::cKey, ; + ::bKey, ::Unique ) ) +RETURN