fivedev/harbour-core
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
fdac3b6883a89ddced64f75e961bf8848bbd61ba
harbour-core/harbour/examples/terminal/terminal.prg
Viktor Szakats 3282d67ff3 2009-07-13 03:15 UTC+0200 Viktor Szakats (harbour.01 syenar.hu) 
* contrib/rddads/adsfunc.c
    % Minor optimizations.
    * Using sizeof() instead of repeating buffer sizes.
    * Formatting.
    - Deleted no more relevant comment.

  * examples/terminal/trm_cli.prg
  * examples/terminal/terminal.prg
    ! Fixes to prev change.
2009-07-13 01:16:06 +00:00

520 lines
14 KiB
Plaintext
Raw Blame History

/*
* $Id$
*/
/*
* Harbour Project source code:
*
* Copyright 2009 Pritpal Bedi <pritpal@vouchcac.com>
* 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.
*
*/
//----------------------------------------------------------------------//
//----------------------------------------------------------------------//
//----------------------------------------------------------------------//
//
// Terminal Server Application
//
// Pritpal Bedi (pritpal@vouchcac.com)
// 13 Feb 2009
//
//----------------------------------------------------------------------//
//----------------------------------------------------------------------//
//----------------------------------------------------------------------//
#include "common.ch"
//#include "wvtwin.ch"
#define WSABASEERR 10000
#define WSAECONNABORTED (WSABASEERR+53)
#define WSAECONNRESET (WSABASEERR+54)
//----------------------------------------------------------------------//
#define TOP t_[ 1 ]
#define LFT t_[ 2 ]
#define BTM t_[ 3 ]
#define RGT t_[ 4 ]
#define ENDBLOCK "|/END\|"
#define TIMER_RECEIVE 1001
#define TIMER_SEND 1002
#define TIMER_PING 1010
#define SND_SCREEN 1 // Through Timer Only
#define SND_CODEBLOCK 2 // Application
#define SND_CLOCKINFO 3
#define SND_CLOCKONOFF 4
#define SND_MUSIC 5
//----------------------------------------------------------------------//
STATIC s_srvrSocket
STATIC s_commSocket
STATIC s_lSendingClient := .F.
STATIC s_mutexSend := hb_mutexCreate()
Function RmtSvrInitialize( cServerInfo, nTimeoutClient, nTimeRefresh )
Local lExit := .t.
s_srvrSocket := NIL
s_commSocket := NIL
DEFAULT nTimeoutClient TO 60 // 60 SECONDS
DEFAULT nTimeRefresh TO .5 // 0.5 SECONDS
nTimeRefresh := 0.1
if !empty( cServerInfo )
if RmtSvrInitAsServer( cServerInfo, @s_srvrSocket, nTimeOutClient*1000 )
if RmtSvrAcceptClient( s_srvrSocket, @s_commSocket )
// Very Important Factor 20-50 No more
//
Hb_INetTimeout( s_commSocket, 10 )
lExit := .f.
RmtSvrRunning( .t. )
hb_threadStart( @Thread_Receive(), 0.05 )
hb_threadStart( @Thread_Send() , nTimeRefresh )
hb_threadStart( @Thread_Ping() , 3 )
// Wvt_SetTimer( TIMER_RECEIVE, 50 ) // 50 ok 1/20 of a second
// Wvt_SetTimer( TIMER_SEND , nTimeRefresh*1000 )
// Wvt_SetTimer( TIMER_PING , 3000 )
endif
endif
endif
if lExit
if s_srvrSocket != NIL
if Hb_INetErrorCode( s_srvrSocket ) == 0
Hb_InetClose( s_srvrSocket )
endif
endif
if s_commSocket != NIL
if Hb_INetErrorCode( s_commSocket ) == 0
Hb_InetClose( s_commSocket )
endif
endif
Hb_INetCleanUp()
endif
Return !( lExit )
//----------------------------------------------------------------------//
Static Function RmtSvrInitAsServer( cServerInfo, Socket, nTimeoutClient )
Local lRet := .f.
Hb_INetInit()
Socket := Hb_INetServer( val( cServerInfo ) )
if Hb_InetErrorCode( Socket ) == 0
lRet := .t.
endif
if lRet
// Wait for 1 minutes maximum : W A T C H INI Controlled
//
Hb_INetTimeout( Socket, nTimeoutClient )
TrmDebug( "SERVER: Connection Established!", hb_INetPort( Socket ) )
else
TrmDebug( "SERVER: Connection Failed" )
endif
Return lRet
//----------------------------------------------------------------------//
//
// Waits for 2 minutes each try
//
Static Function RmtSvrAcceptClient( Socket, pClientSocket )
Local lRet := .t.
// Local i := 0
Do While .t.
pClientSocket := Hb_InetAccept( Socket )
if pClientSocket != NIL
lRet := .t.
endif
exit
//TrmDebug( "SvrConnectClient()", i++, "TRY..." )
enddo
if lRet
TrmDebug( "CLIENT: Connection Established!", hb_INetPort( pClientSocket ) )
else
TrmDebug( "CLIENT: Connection TimedOut!" )
endif
Return .t.
//----------------------------------------------------------------------//
Function RmtSvrSendClient( nMode, xData )
Local cCurs, nError, nBytesSent, nBytesToSend, t_, cOdd, cEvn, cOdd0, cEvn0
Local lSendCurs := .f.
Local lSendScrn := .f.
Local cData := ""
static cCursor := " "
static cSOdd := " "
static cSEvn := " "
static n := 0
static nScreen := 0
n++
if RmtSvrRunning()
if !( s_lSendingClient )
s_lSendingClient := .t.
do case
case nMode == SND_SCREEN
cCurs := hb_ntos( Row() ) +";"+ ;
hb_ntos( Col() ) +";"+ ;
hb_ntos( Set( _SET_CURSOR ) ) +";"
if !( cCurs == cCursor )
lSendCurs := .t.
cCursor := cCurs
endif
t_:= xData
DEFAULT t_ TO { 0, 0, maxrow( .t. ), maxcol( .t. ) }
cOdd := ""
cEvn := ""
GETSCREENATTRIB( TOP,LFT,BTM,RGT,@cOdd,@cEvn )
if !( cSOdd == cOdd ) .or. !( cSEvn == cEvn )
lSendScrn := .t.
cSOdd := cOdd
cSEvn := cEvn
endif
if lSendScrn
nScreen++
cOdd0 := hb_zcompress( cOdd )
cEvn0 := hb_zcompress( cEvn )
cData := '<SCR>' +;
hb_ntos( TOP ) +';'+ hb_ntos( LFT ) +';'+ hb_ntos( BTM ) +';'+ hb_ntos( RGT ) +';'+;
hb_ntos( len( cOdd0 ) ) +';'+ ;
hb_ntos( len( cEvn0 ) ) +';'+ ;
'</E?>' +;
cOdd0 +;
cEvn0 +;
'</E?>' +;
'</SCR>' +;
'<CRS>' + cCurs + '</CRS>' +;
'<ID>' + hb_ntos( nScreen )+ '</ID>'
elseif lSendCurs
cData := '<CRS>'+ cCurs +'</CRS>'
endif
case nMode == SND_CODEBLOCK
cData := '<BLK>'+ xData +'</BLK>'
case nMode == SND_CLOCKINFO
cData := '<CLK_INFO>'+ xData +'</CLK_INFO>'
case nMode == SND_CLOCKONOFF
cData := '<CLK_ONOFF>'+ if( xData, 'TRUE','FALSE' ) +'</CLK_ONOFF>'
case nMode == SND_MUSIC
cData := '<MUSIC>'+ upper( xData ) +'</MUSIC>'
endcase
if len( cData ) > 0
cData += ENDBLOCK
nBytesToSend := len( cData )
nBytesSent := hb_INetSendAll( s_commSocket, cData, nBytesToSend )
if nBytesSent <> nBytesToSend
nError := hb_INetErrorCode( s_commSocket )
TrmDebug( n,'E','VouchServer - SvrSendClient : ', nError, nBytesSent, nBytesToSend )
do case
case ascan( { -2, WSAECONNABORTED, WSAECONNRESET }, nError ) > 0
TrmDebug( n,'Q','VouchServer - SvrSendClient : ', nError, nBytesSent, nBytesToSend )
DbCloseAll()
Quit
otherwise
endcase
endif
endif
s_lSendingClient := .f.
endif
endif
Return nil
//----------------------------------------------------------------------//
Static Function RmtSvrReceiveClient()
Local cKey, nBytes, nError
static lInProcess := .f.
if !lInProcess
if hb_INetDataReady( s_commSocket ) > 0
lInProcess := .t.
cKey := hb_INetRecvLine( s_commSocket, @nBytes )
if nBytes > 0
hb_KeyPut( Val( cKey ) )
elseif nBytes == 1
else
nError := hb_INetErrorCode( s_commSocket )
if ascan( { -2, WSAECONNABORTED, WSAECONNRESET }, nError ) > 0
TrmDebug( 'VouchAsServer - Quitting : Error =', hb_INetErrorCode( s_commSocket ), 'nBytes =', nBytes )
DbCloseAll()
Quit
endif
endif
lInProcess := .f.
endif
endif
Return nil
//----------------------------------------------------------------------//
// Required as this receive all timer events
//
Function Wvt_Timer( wParam )
switch wParam
case TIMER_RECEIVE
RmtSvrReceiveClient()
exit
case TIMER_SEND
RmtSvrSendClient( 1, NIL )
exit
case TIMER_PING
if !( s_lSendingClient )
hb_INetSendAll( s_commSocket, ENDBLOCK )
endif
exit
end
Return 0
STATIC PROCEDURE Thread_Receive( nWait )
DO WHILE .T.
RmtSvrReceiveClient()
hb_idleSleep( nWait )
ENDDO
RETURN
STATIC PROCEDURE Thread_Send( nWait )
DO WHILE .T.
hb_mutexLock( s_mutexSend )
RmtSvrSendClient( 1, NIL )
hb_mutexUnlock( s_mutexSend )
hb_idleSleep( nWait )
ENDDO
RETURN
STATIC PROCEDURE Thread_Ping( nWait )
DO WHILE .T.
hb_mutexLock( s_mutexSend )
hb_INetSendAll( s_commSocket, ENDBLOCK )
hb_mutexUnlock( s_mutexSend )
hb_idleSleep( nWait )
ENDDO
RETURN
//----------------------------------------------------------------------//
Function RmtSvrSetInfo( cnInfo )
Local xInfo
static aInfo := { NIL,NIL,NIL }
if valtype( cnInfo ) == 'C' // To Retrieve it will be N
aInfo[ 1 ] := val( cnInfo ) // Port to Use
elseif valtype( cnInfo ) == 'N'
xInfo := aInfo[ cnInfo ]
endif
Return xInfo
//----------------------------------------------------------------------//
Function RmtSvrRunning( lYes )
Local sYes
static oYes := .f.
sYes := oYes
if valtype( lYes ) == 'L'
oYes := lYes
endif
return sYes
//----------------------------------------------------------------------//
Function TrmStr2A( cStr, cDel )
Local a_:={}, n
Local nlen
nLen := len( cDel )
do while .t.
if ( n := at( cDel, cStr ) ) == 0
exit
endif
aadd( a_, substr( cStr,1,n-1 ) )
cStr := substr( cStr,n+nLen )
enddo
Return a_
//----------------------------------------------------------------------//
Function TrmDebug( p1,p2,p3,p4,p5,p6,p7,p8,p9,p10 )
Local cDebug := ''
if p1 <> nil
cDebug += TrmXtoS( p1 )
endif
if p2 <> nil
cDebug += ' ' + TrmXtoS( p2 )
endif
if p3 <> nil
cDebug += ' ' + TrmXtoS( p3 )
endif
if p4 <> nil
cDebug += ' ' + TrmXtoS( p4 )
endif
if p5 <> nil
cDebug += ' ' + TrmXtoS( p5 )
endif
if p6 <> nil
cDebug += ' ' + TrmXtoS( p6 )
endif
if p7 <> nil
cDebug += ' ' + TrmXtoS( p7 )
endif
if p8 <> nil
cDebug += ' ' + TrmXtoS( p8 )
endif
if p9 <> nil
cDebug += ' ' + TrmXtoS( p9 )
endif
if p10 <> nil
cDebug += ' ' + TrmXtoS( p10 )
endif
#if defined( __PLATFORM__WINDOWS )
wapi_OutputDebugString( cDebug )
#endif
Return nil
//----------------------------------------------------------------------//
FUNCTION TrmXtoS( xVar )
SWITCH ValType( xVar )
CASE "C"
RETURN xVar
CASE "N"
RETURN Str( xVar )
CASE "D"
RETURN DToC( xVar )
CASE "L"
RETURN iif( xVar, "T", "F" )
ENDSWITCH
RETURN "NIL"
//----------------------------------------------------------------------//
Function TrmDummy()
Return nil
//----------------------------------------------------------------------//
STATIC PROCEDURE GETSCREENATTRIB( nT, nL, nB, nR, cOdd, cEvn )
LOCAL s := SaveScreen( nT, nL, nB, nR )
cOdd := CharOdd( s )
cEvn := CharEven( s )
RETURN
Reference in New Issue View Git Blame Copy Permalink