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

XWBLDDD.m

Go to the documentation of this file. 
  1. XWBTCPL ;SLC/KCM - Listener for TCP connects [ 02/13/95  9:01 PM ] ;10/16/96  11:33
  1.  ;;1.1T3;RPC BROKER;;Nov 25, 1996
  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 s small routine to listen for new requests
  1.  ; on the known service port.
  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.  ;
  1. EN(XWBTSKT) ; -- accept clients and start the individual message handler
  1.  N IP,REF,RETRY,XWBVER
  1.  S U="^"
  1.  S RETRY="START"
  1.  X ^%ZOSF("UCI") S REF=Y
  1.  S IP="0.0.0.0" ;get server IP
  1.  IF $G(XWBTSKT)="" S XWBTSKT=9000 ; default service port
  1.  S XWBTDEV=XWBTSKT
  1.  ;
  1.  D SETNM^%ZOSV($E("RPCB_Port:"_XWBTSKT,1,15)) ;change process name
  1.  N LEN,MSG,XWBOS,DONE,DSMTCP,X
  1.  ; -- check the TCP stop parameter
  1.  ;IF $G(^XWB(IP,REF,XWBTSKT,"STOP")) K ^XWB(IP,REF,XWBTSKT) Q   ; -- change to param file later ***
  1.  Q:'$$SEMAPHOR(XWBTSKT,"LOCK")  ; -- quit if job is already running
  1.  ;
  1.  D UPDTREC(XWBTSKT,3) ;updt RPC BROKER SITE PARAMETER record as RUNNING
  1.  ;
  1. RESTART ;
  1.  S DONE=0
  1.  S XWBOS=$S(^%ZOSF("OS")["DSM":"DSM",^("OS")["MSM":"MSM",^("OS")["OpenM":"OpenM",1:"")
  1.  IF $$NEWERR^%ZTER N $ESTACK S $ETRAP="S %ZTER11S=$STACK D ETRAP^XWBTCPL"
  1.  E  S X="ETRAP^XWBTCPL",@^%ZOSF("TRAP")
  1.  ;
  1.  ; -- check the TCP stop parameter
  1.  ;IF $G(^XWB(IP,REF,XWBTSKT,"STOP")) K ^XWB(IP,REF,XWBTSKT) Q   ; -- change to param file later ***
  1.  ;
  1.  I XWBOS="DSM" O XWBTSKT:TCPCHAN:5 ;Open listener
  1.  ; -- loop until TCP stop parameter is set
  1.  ;F  D  Q:$G(^XWB(IP,REF,XWBTSKT,"STOP"))
  1.  F  D  Q:DONE
  1.  . L +^XWB(IP,REF,XWBTSKT,"PROBLEM MARKER")
  1.  . K ^XWB(IP,REF,XWBTSKT,"PROBLEM MARKER")   ;clear problem marker
  1.  . L -^XWB(IP,REF,XWBTSKT,"PROBLEM MARKER")
  1.  . ;
  1.  . ; -- listen for connect & get the initial message from the client
  1.  . I XWBOS="DSM" U XWBTSKT
  1.  . I XWBOS="MSM" S XWBTDEV=56 O 56 U 56::"TCP" W /SOCKET("",XWBTSKT)
  1.  . I XWBOS="OpenM" S XWBTDEV="|TCP|"_XWBTSKT O XWBTDEV:(:XWBTSKT:"AT") U XWBTDEV R *X
  1.  . S XWBVER=0
  1.  . R LEN#11 IF $E(LEN,1,5)'="{XWB}" Q
  1.  . IF $E(LEN,11,11)="|" D
  1.  . . R X#1
  1.  . . R XWBVER#$A(X)
  1.  . . R LEN#5
  1.  . . R MSG#LEN
  1.  . ELSE  S X=$E(LEN,11,11),LEN=$E(LEN,6,10)-1 R MSG#LEN S MSG=X_MSG
  1.  . ; -- msg should be:  action^client IP^client port^token
  1.  . ;
  1.  . ; -- if the action is TCPconnect (usual case)
  1.  . I $P(MSG,"^")="TCPconnect" D
  1.  . . ;-- decrypt token
  1.  . . N X,%T S X="",%T=0
  1.  . . IF XWBOS="DSM" J EN^XWBTCPC($P(MSG,"^",2),$P(MSG,"^",3),$P(X,"^"),XWBVER):OPTION="/SYMBOL=100000":5 S %T=$T
  1.  . . IF XWBOS="MSM" J EN^XWBTCPC($P(MSG,"^",2),$P(MSG,"^",3),$P(X,"^"),XWBVER):100000:5 S %T=$T
  1.  . . I XWBOS="OpenM" J EN^XWBTCPC($P(MSG,"^",2),$P(MSG,"^",3),$P(X,"^"),XWBVER)::5 S %T=$T
  1.  . . I %T D SNDERR W "accept",$C(4),!
  1.  . . E  D SNDERR W "reject",$C(4),! S ^TMP("TCP",$P($H,",",2))="REJECT"
  1.  . ;
  1.  . ; -- if the action is TCPdebug (when msg handler run interactively)
  1.  . I $P(MSG,"^")="TCPdebug" D SNDERR W "accept",$C(4),!
  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 W "ack",!
  1.  . ;Now release the connection.
  1.  . I XWBOS="DSM" U XWBTSKT:DISCONNECT ; release this socket
  1.  . I XWBOS="MSM" C 56
  1.  . I XWBOS="OpenM" C XWBTDEV
  1.  . Q
  1.  ; -- loop end
  1.  ;
  1.  IF XWBOS="DSM" C XWBTSKT
  1.  S %=$$SEMAPHOR(XWBTSKT,"UNLOCK") ; destroy 'running flag'
  1.  ;K ^XWB(IP,REF,XWBTSKT,"STOP")
  1.  D UPDTREC(XWBTSKT,6) ;updt RPC BROKER SITE PARAMETER record as STOPPED
  1.  Q
  1.  ;
  1. ETRAP   ; -- on trapped error, send error info to client
  1.  N XWBERR
  1.  S XWBERR=$C(24)_"M  ERROR="_$ZERROR_$C(13,10)_"LAST REF="_$ZR_$C(4)
  1.  D ^%ZTER ;Record it
  1.  S RETRY=RETRY+1 H 3
  1.  IF RETRY=5 H  ;give up trying, server should not restart
  1.  IF $$NEWERR^%ZTER S $ETRAP="Q:($ESTACK&'$QUIT)  Q:$ESTACK 0 S $ECODE="""" G RESTART^XWBTCPL"
  1.  IF XWBOS="DSM" D
  1.  . I $D(XWBTLEN),XWBTLEN,$ZE'["SYSTEM-F" D SNDERR W XWBERR
  1.  IF XWBOS'="DSM" D  G RESTART
  1.  . D SNDERR W XWBERR
  1.  S $ECODE=",U1," Q  ;Pass error up to pop stack.
  1.  ;
  1. SNDERR ;send error information
  1.  ;XWBSEC is the security packet, XWBERROR is application packet
  1.  N X
  1.  S X=$G(XWBSEC)
  1.  W $C($L(X))_X
  1.  S X=$G(XWBERROR)
  1.  W $C($L(X))_X W !
  1.  S XWBERROR="" ;clears parameters
  1.  Q
  1.  ;
  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