Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XWBTCPL

XWBTCPL.m

Go to the documentation of this file. 
  1. XWBTCPL ;SLC/KCM - Listener for TCP connects ;12/09/2004  07:33
  1.  ;;1.1;RPC BROKER;**1,7,9,15,16,35**;Mar 28, 1997
  1.  ;ISC-SF/EG - DHCP Broker
  1.  ;
  1.  ; This routine is the background process that listens for client
  1.  ; requests to connect to M.  When a request is received, This
  1.  ; procedure will job a routine to handle the requests of the client.
  1.  ;
  1.  ; This job may be started in the background with:  D STRT^XWBTCP(PORT)
  1.  ;
  1.  ; When running, this job may be stopped with:      D STOP^XWBTCP(PORT)
  1.  ;
  1.  ; Where port is the known service port to listen for connections
  1.  ; p*35 Moved reads and writes to XWBRW
  1.  ;
  1. EN(XWBTSKT) ; -- accept clients and start the individual message handler
  1.  N $ETRAP,$ESTACK S $ETRAP="D ^%ZTER J EN^XWBTCPL($G(XWBTSKT)) HALT"
  1.  N RETRY,X,XWBVER,XWBVOL,LEN,MSG,XWBOS,DONE,DSMTCP,NATIP,XWBRBUF
  1.  N XWBTIME
  1.  S U="^",RETRY="START"
  1.  X ^%ZOSF("UCI") S XWBVOL=$P(Y,",",2) ;(*p7,p9*)
  1.  IF $G(XWBTSKT)="" S XWBTSKT=9000 ; default service port
  1.  S XWBTDEV=XWBTSKT
  1.  ;
  1.  Q:'$$SEMAPHOR(XWBTSKT,"LOCK")  ; -- quit if job is already running
  1.  ;
  1.  S XWBDEBUG=$$GET^XPAR("SYS","XWBDEBUG") ;(*p35)
  1.  I XWBDEBUG D LOGSTART^XWBDLOG("XWBTCPL") ;(*p35)
  1.  D UPDTREC(XWBTSKT,3) ;updt RPC BROKER SITE PARAMETER record as RUNNING
  1.  D MARKER^XWBTCP(XWBTSKT,-1) ;Clear marker
  1.  ;
  1.  D SETNM^%ZOSV($E("RPCB_Port:"_XWBTSKT,1,15)) ;change process name
  1.  ;
  1. RESTART ;
  1.  H 5 ;Hibernate so caller can clear (*p16,*p35)
  1.  N $ESTACK S $ETRAP="D ETRAP^XWBTCPL"
  1.  S DONE=0,X=0,XWBTIME=5,XWBTIME(1)=5
  1.  S XWBOS=$S(^%ZOSF("OS")["DSM":"DSM",^("OS")["OpenM":"OpenM",^("OS")["GT.M":"GTM",^("OS")["MSM":"MSM",1:"")
  1.  S XWBT("BF")=$S(XWBOS="GT.M":"#",1:"!") ;(*p35)
  1.  ;
  1.  S %T=0 ;Check for Open success (*p35)
  1.  ;DSM
  1.  I XWBOS="DSM" O XWBTSKT:TCPCHAN:5 S %T=$T ;Open listener
  1.  ;Cache, Terminator = $C(4)512 buffers, queue = 10
  1.  I XWBOS="OpenM" S XWBTDEV="|TCP|"_XWBTSKT O XWBTDEV:(:XWBTSKT:"A":$C(4):512:512:10):5 S %T=$T ;(*p35)
  1.  ;GT.M (*p35)
  1.  I XWBOS="GTM" D
  1.  . S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""")
  1.  . S XWBTDEV="SKD$"_$J,XWBTSKT=XWBTSKT
  1.  . O XWBTDEV:(ZLISTEN=XWBTSKT_":TCP":NODELIMITER:ATTACH="listener"):5:"SOCKET" S %T=$T Q:'%T
  1.  . U XWBTDEV S XWBTDEV("LISTENER")=$KEY
  1.  . W /LISTEN(1)
  1.  . U XWBTDEV S XWBTDEV("STATUS")=$KEY
  1.  . Q
  1.  ;Check if got device Open
  1.  I '%T D LOG^XWBDLOG("Open "_XWBTSKT_" Fail") Q  ;(*p35)
  1.  ;
  1.  I XWBDEBUG D LOG^XWBDLOG("Port Open: "_XWBTSKT)
  1.  F  D  Q:DONE
  1.  . S DONE=0
  1.  . ; -- listen for connect & get the initial message from the client
  1.  . I XWBOS="DSM" U XWBTSKT S XWBTIME=60 ;Will wait at read
  1.  . I XWBOS="MSM" S XWBTDEV=56 O 56 U 56::"TCP" W /SOCKET("",XWBTSKT)
  1.  . I XWBOS="OpenM" U XWBTDEV R *X ;Cache will wait here for connection
  1.  . I XWBOS="GTM" D
  1.  . . K XWBTDEV("SOCKET")
  1.  . . F  D  Q:$D(XWBTDEV("SOCKET"))
  1.  . . . ;Wait for connection, $KEY will be "CONNECT|socket_handle|remote_ipaddress"
  1.  . . . U XWBTDEV W /WAIT(10) S XWBTDEV("KEY")=$KEY
  1.  . . . I XWBTDEV("KEY")="" Q
  1.  . . . S XWBTDEV("SOCKET")=$P(XWBTDEV("KEY"),"|",2)
  1.  . . . S (XWBTDEV("IP"),IO("GTM-IP"))=$P(XWBTDEV("KEY"),"|",3)
  1.  . . . U XWBTDEV:(SOCKET=XWBTDEV("SOCKET"):WIDTH=512:NOWRAP:EXCEPTION="GOTO ETRAP")
  1.  . . . Q
  1.  . . Q
  1.  . ;========================MAIN LOOP=======================
  1.  . ;(*p35) change to use MSG, MSG1 and MSG2
  1.  . S (MSG,MSG1,MSG2,XWBRBUF)=""
  1.  . ;F XCNT=0:0 R MSG1#1:XWBTIME Q:$T  I '$T S XCNT=XCNT+1 Q:XCNT>5
  1.  . F XCNT=0:0 S MSG1=$$BREAD^XWBRW(1,XWBTIME,1) Q:$L(MSG1)  S XCNT=XCNT+1 Q:XCNT>5
  1.  . Q:XCNT>5
  1.  . I MSG1'="{" D RELEASE(0) Q  ;Not the right start so Close.
  1.  . S MSG1=MSG1_$$BREAD^XWBRW(4,,1) IF (MSG1'="{XWB}") D RELEASE(0) Q
  1.  . S MSG1=MSG1_$$BREAD^XWBRW(6)
  1.  . I $E(MSG1,11)="|" D
  1.  . . S VL=$$BREAD^XWBRW(1),VL=$A(VL)
  1.  . . S XWBVER=$$BREAD^XWBRW(VL)
  1.  . . S LEN=$$BREAD^XWBRW(5)
  1.  . . S MSG=$$BREAD^XWBRW(+LEN)
  1.  . E  S X=$E(MSG1,11),LEN=$E(MSG1,6,10)-1,MSG2=$$BREAD^XWBRW(LEN),MSG=X_MSG2,XWBVER=0
  1.  . ; -- msg should be:  action^client IP^client port^token
  1.  . I XWBDEBUG D LOG^XWBDLOG("Hdr:"_MSG1_" Msg:"_MSG) ;(*p35)
  1.  . ;
  1.  . ; -- if the action is TCPconnect (usual case)
  1.  . I $P(MSG,"^")="TCPconnect" D
  1.  . . N DZ,%T S DZ="",%T=0,RETRY=$S($G(RETRY)>1:RETRY-1,1:0) ;(*p7*)
  1.  . . ;Get the peer and use that IP, Allow use thru a NAT box.
  1.  . . S NATIP=$$GETPEER^%ZOSV I $L(NATIP) S $P(MSG,"^",2)=NATIP ;(*p35)
  1.  . . I '$$NEWJOB D QSND("reject") Q  ;(*p7,*p35)
  1.  . . I XWBDEBUG>1 D LOG^XWBDLOG("JOB: "_MSG)
  1.  . . ;Job a Server, X should be null
  1.  . . J EN^XWBTCPC($P(MSG,"^",2),$P(MSG,"^",3),$P(DZ,"^"),XWBVER,$P(MSG,"^",4))::5 S %T=$T
  1.  . . I %T D QSND("accept") ;(*p35)
  1.  . . I '%T  D QSND("reject") ;(*p35)
  1.  . ;
  1.  . ; -- if the action is TCPdebug (when msg handler run interactively)
  1.  . I $P(MSG,"^")="TCPdebug" D QSND("accept") ;(*p35)
  1.  . ;
  1.  . ; -- if the action is TCPshutdown, this listener will quit if the
  1.  . ;    stop flag has been set.  This request comes from an M process.
  1.  . I $P(MSG,"^")="TCPshutdown" S DONE=1 D QSND^XWBRW("ack")
  1.  . D RELEASE(0) ;Now release the connection. (*p7*)
  1.  . Q
  1.  ; -- loop end
  1.  ;
  1.  S %=$$SEMAPHOR(XWBTSKT,"UNLOCK") ; destroy 'running flag'
  1.  D LOG^XWBDLOG("Exit")
  1.  D UPDTREC(XWBTSKT,6) ;updt RPC BROKER SITE PARAMETER record as STOPPED
  1.  S $ETRAP="" ;(*p35) Turn off error trap
  1.  IF XWBOS="DSM" C XWBTSKT ;Do Close last in case it gets an error
  1.  Q
  1.  ;
  1. QSND(STR) ;Write output (*p35)
  1.  D QSND^XWBRW(STR),LOG^XWBDLOG(STR)
  1.  Q
  1.  ;
  1. ETRAP ; -- on trapped error, send error info to client
  1.  N XWBERC,XWBERR S $ETRAP="D ^%ZTER J EN^XWBTCPL($G(XWBTSKT)) HALT"
  1.  S XWBERC=$$EC^%ZOSV,XWBERR=$C(24)_"M  ERROR="_XWBERC_$C(13,10)_"LAST REF="_$$LGR^%ZOSV
  1.  D ^%ZTER ;Record error and clear $ECODE
  1.  D LOG^XWBDLOG("Error: "_$E(XWBERC,1,200))
  1.  S RETRY=$G(RETRY)+1 H 3+(RETRY\5) ;(*p7*) Slow down but never stop
  1.  ;Halt if DSM DUPNAME
  1.  I XWBERC["F-DUPLNAM" D  HALT
  1.  . S %=$$SEMAPHOR(XWBTSKT,"UNLOCK") ; destroy 'running flag'
  1.  . D UPDTREC(XWBTSKT,6) ;updt RPC BROKER SITE PARAMETER record as STOPPED
  1.  . Q
  1.  S XWBDEBUG=$G(XWBDEBUG)
  1.  ;Set new trap
  1.  S $ETRAP="Q:($ESTACK&'$QUIT)  Q:$ESTACK -9 S $ECODE="""" G RESTART^XWBTCPL"
  1.  ;
  1.  I (XWBERC["READ")!(XWBERC["WRITE")!(XWBERC["SYSTEM-F") G ETRAPX
  1.  IF XWBOS="DSM" D
  1.  . I $D(XWBTLEN),XWBTLEN,XWBERC'["SYSTEM-F" D QSND(XWBERR) ;(p35)
  1.  IF XWBOS="OpenM",XWBERC'["<WRITE>" D QSND(XWBERR) ;(*p7,35*)
  1.  IF XWBOS="MSM" D QSND(XWBERR) ;(*p7,35*)
  1. ETRAPX D RELEASE(1) ;Now close the connection. (*p7*)
  1.  I XWBOS="DSM" H 15 ;Wait for device to close 
  1.  S $ECODE=",U1," Q  ;Pass error up to pop stack.
  1.  ;
  1. FLUSH ;Flush the input buffer
  1.  F  R X:0 Q:'$T
  1.  Q
  1.  ;
  1. RELEASE(%) ;Now release the connection. (*p7*)
  1.  ;Parameter is zero to Release, one to Close
  1.  I XWBOS="DSM" D  Q  ;(*p35)
  1.  . I $G(%) C XWBTSKT Q
  1.  . U XWBTSKT:DISCONNECT ; release this socket
  1.  I XWBOS="OpenM" D  Q  ;(*p35)
  1.  . I $G(%) C XWBTDEV Q
  1.  . W *-2 ;Release the socket
  1.  I XWBOS="GTM" D  Q  ;(*p35)
  1.  . I $G(%) C XWBTDEV Q
  1.  . C XWBTDEV:(SOCKET=XWBTDEV("SOCKET")) ;release the socket
  1.  I XWBOS="MSM" C 56
  1.  Q
  1.  ;
  1. UPDTREC(XWBTSKT,STATE,XWBENV) ; -- update STATUS field and ^%ZIS X-ref of the
  1.  ;RPC BROKER SITE PARAMETER file
  1.  ;XWBTSKT: listener port
  1.  N C,XWBOXIEN,XWBPOIEN,XWBFDA
  1.  S C=",",U="^"
  1.  I $G(XWBENV)'="" S Y=XWBENV
  1.  E  D GETENV^%ZOSV ;get Y=UCI^VOL^NODE^BOXLOOKUP of current system
  1.  ;I STATE=3 S ^%ZIS(8994.171,"RPCB Listener",$P(Y,U,2),$P(Y,U),$P(Y,U,4),XWBTSKT)=$J
  1.  ;I STATE=6 K ^%ZIS(8994.171,"RPCB Listener",$P(Y,U,2),$P(Y,U),$P(Y,U,4),XWBTSKT)
  1.  ;
  1.  S XWBOXIEN=$$FIND1^DIC(8994.17,",1,","",$P(Y,U,4)) ;find rec for box
  1.  S XWBPOIEN=$$FIND1^DIC(8994.171,C_XWBOXIEN_",1,","",XWBTSKT)
  1.  D:XWBPOIEN>0  ;update STATUS field if entry was found
  1.  . D FDA^DILF(8994.171,XWBPOIEN_C_XWBOXIEN_C_1_C,1,"R",STATE,"XWBFDA")
  1.  . D FILE^DIE("","XWBFDA")
  1.  Q
  1.  ;
  1.  ;
  1. SEMAPHOR(XWBTSKT,XWBACT) ;Lock/Unlock listener semaphore
  1.  ;XWBTSKT: listener port, XWBACT: "LOCK" | "UNLOCK" action to perform
  1.  ;if LOCK is requested, it will be attempted with 1 sec timeout and if
  1.  ;lock was obtained RESULT will be 1, otherwise it will be 0.  For
  1.  ;unlock RESULT will always be 1.
  1.  N RESULT
  1.  S U="^",RESULT=1
  1.  D GETENV^%ZOSV ;get Y=UCI^VOL^NODE^BOXLOOKUP of current system
  1.  I XWBACT="LOCK" D
  1.  . L +^%ZIS(8994.171,"RPCB Listener",$P(Y,U,2),$P(Y,U),$P(Y,U,4),XWBTSKT):1
  1.  . S RESULT=$T
  1.  E  L -^%ZIS(8994.171,"RPCB Listener",$P(Y,U,2),$P(Y,U),$P(Y,U,4),XWBTSKT)
  1.  Q RESULT
  1.  ;
  1. NEWJOB() ;Check if OK to start a new job, Return 1 if OK, 0 if not OK.
  1.  N X,Y,XQVOL,XUVOL
  1.  S X=$O(^XTV(8989.3,1,4,"B",XWBVOL,0)),XUVOL=$S(X>0:^XTV(8989.3,1,4,X,0),1:"ROU^y^1"),XQVOL=XWBVOL
  1.  S X=$$INHIBIT^XUSRB ;Returns 1 if new logons are inhibited.
  1.  Q 'X