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

XWBTCPM.m

Go to the documentation of this file.
  1. XWBTCPM ;ISF/RWF - BROKER TCP/IP PROCESS HANDLER ;05/27/15 14:40
  1. ;;1.1;RPC BROKER;**35,43,49,53,64**;Mar 28, 1997;Build 12
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ;Changed to be started by TCPIP service or %ZISTCPS
  1. ;
  1. DSM ;DSM called from ucx, % passed in with device.
  1. D ESET
  1. ;Open the device
  1. S XWBTDEV=% X "O XWBTDEV:(TCPDEV):60" ;Special UCX/DSM open
  1. ;Go find the connection type
  1. U XWBTDEV
  1. G CONNTYPE
  1. ;
  1. CACHEVMS ;Cache'/VMS tcpip entry point, called from XWBTCP_START.COM file
  1. D ESET
  1. S XWBTDEV=$S($ZV["VMS":"SYS$NET",1:$P) ;Support for both VMS/TCPIP and Linux/xinetd
  1. ; **Cache'/VMS specific code**
  1. O XWBTDEV::5
  1. X "U XWBTDEV:(::""-M"")" ;Packet mode like DSM
  1. G CONNTYPE
  1. ;
  1. NT ;entry from ZISTCPS
  1. ;JOB LISTEN^%ZISTCPS("port","NT^XWBTCPM","stop code")
  1. D ESET
  1. S XWBTDEV=IO
  1. G CONNTYPE
  1. ;
  1. GTMUCX(%) ;From ucx ZFOO
  1. ;If called from LISTEN^%ZISTCP(PORT,"GTM^XWBTCPM") S XWBTDEV=IO
  1. D ESET
  1. ;GTM specific code
  1. S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""")
  1. S XWBTDEV=% X "O %:(RECORDSIZE=512)"
  1. G CONNTYPE
  1. ;
  1. GTMLNX ;From Linux xinetd script
  1. D ESET
  1. ;GTM specific code
  1. S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""")
  1. S XWBTDEV=$P X "U XWBTDEV:(nowrap:nodelimiter:ioerror=""TRAP"")"
  1. S %="",@("%=$ZTRNLNM(""REMOTE_HOST"")") S:$L(%) IO("GTM-IP")=%
  1. G CONNTYPE
  1. ;
  1. ESET ;Set inital error trap
  1. S U="^",$ETRAP="D ^%ZTER H" ;Set up the error trap
  1. S X="",@("$ZT=X") ;Clear old trap
  1. Q
  1. ;Find the type of connection and jump to the processing routine.
  1. CONNTYPE ;
  1. N XWBDEBUG,XWBAPVER,XWBCLMAN,XWBENVL,XWBLOG,XWBOS,XWBPTYPE
  1. N XWBTBUF,XWBTIP,XWBTSKT,XWBVER,XWBWRAP,XWBSHARE,XWBT
  1. N SOCK,TYPE
  1. D INIT
  1. S XWB=$$BREAD^XWBRW(5,XWBTIME)
  1. D LOG("MSG format is "_XWB_" type "_$S(XWB="[XWB]":"NEW",XWB="{XWB}":"OLD",XWB="<?xml":"M2M",XWB="~BSE~":"BSE",XWB="~EAC~":"EAC",XWB="~SVR~":"SVR",1:"Unk")) ; XWB*1.1*XX
  1. I XWB["<?xml" G M2M
  1. I XWB["[XWB]" G NEW
  1. I XWB["{XWB}" G OLD^XWBTCPM1 ;Deprecated in XWB*1.1*60, to be removed when no longer being used
  1. I $L($T(OTH^XWBTCPM2)) D OTH^XWBTCPM2 ;See if a special code.
  1. I '$L($T(OTH^XWBTCPM2)) D LOG("Prefix not known: "_XWB) ; XWB*1.1*XX
  1. Q
  1. ;
  1. NEWJOB() ;Check if OK to start a new job, Return 1 if OK, 0 if not OK.
  1. N X,Y,J,XWBVOL
  1. D GETENV^%ZOSV S XWBVOL=$P(Y,"^",2)
  1. S X=$O(^XTV(8989.3,1,4,"B",XWBVOL,0)),J=$S(X>0:^XTV(8989.3,1,4,X,0),1:"ROU^y^1")
  1. I $G(^%ZIS(14.5,"LOGON",XWBVOL)) Q 0 ;Check INHIBIT LOGONS?
  1. I $D(^%ZOSF("ACTJ")) X ^("ACTJ") I $P(J,U,3),($P(J,U,3)'>Y) Q 0
  1. Q 1
  1. ;
  1. M2M ;M2M Broker
  1. S XWBRBUF=XWB_XWBRBUF,(IO,IO(0))=XWBTDEV G SPAWN^XWBVLL
  1. Q
  1. ;
  1. NEW ;New broker
  1. S U="^",DUZ=0,DUZ(0)="",XWBVER=1.108
  1. D SETTIME(1) ;Setup for sign-on timeout
  1. U XWBTDEV D
  1. . N XWB,ERR,NATIP,I
  1. . S ERR=$$PRSP^XWBPRS
  1. . S ERR=$$PRSM^XWBPRS
  1. . S MSG=$G(XWB(4,"CMD")) ;Build connect msg.
  1. . S I="" F S I=$O(XWB(5,"P",I)) Q:I="" S MSG=MSG_U_XWB(5,"P",I)
  1. . ;Get the peer and save that IP.
  1. . S NATIP=$$GETPEER^%ZOSV S:'$L(NATIP) NATIP=$P(MSG,"^",2)
  1. . I NATIP'=$P(MSG,"^",2) S $P(MSG,"^",2)=NATIP
  1. . Q
  1. S X=$$NEWJOB() D:'X LOG("No New Connects")
  1. I ($P(MSG,U)'="TCPConnect")!('X) D QSND^XWBRW("reject"),LOG("reject: "_MSG) Q
  1. D QSND^XWBRW("accept"),LOG("accept") ;Ack
  1. S IO("IP")=$P(MSG,U,2),XWBTSKT=$P(MSG,U,3),XWBCLMAN=$P(MSG,U,4)
  1. S XWBTIP=$G(IO("IP"))
  1. ;start RUM for Broker Handler XWB*1.1*5
  1. D LOGRSRC^%ZOSV("$BROKER HANDLER$",2,1)
  1. ;GTM
  1. I $G(XWBT("PCNT")) D
  1. . S X=$NA(^XUTL("XUSYS",$J,1)) L +@X:0
  1. . D COUNT^XUSCNT(1),SETLOCK^XUSCNT(X)
  1. ;We don't use a callback
  1. K XWB,CON,LEN,MSG ;Clean up
  1. ;Attempt to share license, Must have TCP port open first.
  1. U XWBTDEV ;D SHARELIC^%ZOSV(1)
  1. ;setup null device "NULL"
  1. S %ZIS="0H",IOP="NULL" D ^%ZIS S XWBNULL=IO I POP S XWBERROR="No NULL device" D LOG(XWBERROR),EXIT Q
  1. D SAVDEV^%ZISUTL("XWBNULL")
  1. ;change process name
  1. D CHPRN("ip"_$P(XWBTIP,".",3,4)_":"_XWBTDEV)
  1. ;
  1. RESTART ;The error trap returns to here
  1. N $ESTACK S $ETRAP="D ETRAP^XWBTCPM(0)"
  1. S DT=$$DT^XLFDT,DTIME=30
  1. U XWBTDEV D MAIN
  1. D LOG("Exit: "_XWBTBUF)
  1. ;Turn off the error trap for the exit
  1. S $ETRAP=""
  1. D EXIT ;Logout
  1. K XWBR,XWBARY
  1. ;stop RUM for handler XWB*1.1*5
  1. D LOGRSRC^%ZOSV("$BROKER HANDLER$",2,2)
  1. D USE^%ZISUTL("XWBNULL"),CLOSE^%ZISUTL("XWBNULL")
  1. ;Close in the calling script
  1. K SOCK,TYPE,XWBSND,XWBTYPE,XWBRBUF
  1. Q
  1. ;
  1. MAIN ; -- main message processing loop. debug at MAIN+1
  1. F D Q:XWBTBUF="#BYE#"
  1. . ;Setup
  1. . S XWBAPVER=0,XWBTBUF="",XWBTCMD="",XWBRBUF=""
  1. . K XWBR,XWBARY,XWBPRT
  1. . ; -- read client request
  1. . S XR=$$BREAD^XWBRW(1,XWBTIME,1)
  1. . I '$L(XR) D LOG("Timeout: "_XWBTIME) S XWBTBUF="#BYE#" Q
  1. . S XR=XR_$$BREAD^XWBRW(4)
  1. . I XR="#BYE#" D Q ;Check for exit
  1. . . D QSND^XWBRW("#BYE#"),LOG("BYE CMD") S XWBTBUF="#BYE#"
  1. . . Q
  1. . S TYPE=(XR="[XWB]") ;check HDR
  1. . I 'TYPE D LOG("Bad Header: "_XR) Q
  1. . D CALLP^XWBPRS(.XWBR,$G(XWBDEBUG)) ;Read the NEW Msg parameters and call RPC
  1. . IF XWBTCMD="#BYE#" D Q
  1. . . D QSND^XWBRW("#BYE#"),LOG("BYE CMD") S XWBTBUF=XWBTCMD
  1. . . Q
  1. . U XWBTDEV
  1. . S XWBPTYPE=$S('$D(XWBPTYPE):1,XWBPTYPE<1:1,XWBPTYPE>6:1,1:XWBPTYPE)
  1. . ;I $G(XWBPRT) D RETURN^XWBPRS2 Q ;New msg return
  1. . I '$G(XWBPRT) D SND^XWBRW ;Return data,flush buffer
  1. Q ;End Of Main
  1. ;
  1. ;
  1. ETRAP(EXIT) ; -- on trapped error, send error info to client
  1. N XWBERC,XWBERR
  1. ;Change trapping during trap.
  1. S $ETRAP="D ^%ZTER,ETRAP^XWBTCPM(1)"
  1. S XWBERC=$E($$EC^%ZOSV,1,200),XWBERR="M ERROR="_XWBERC_$C(13,10)_"LAST REF="_$$LGR^%ZOSV
  1. I $EC["U411" S XWBERROR="U411",XWBSEC="",XWBERR="Data Transfer Error to Server"
  1. D ^%ZTER ;%ZTER clears $ZE and $ZCODE
  1. D LOG("In ETRAP: "_XWBERC) ;Log
  1. I (XWBERC["READ")!(XWBERC["WRITE")!(XWBERC["SYSTEM-F")!(XWBERC["IOEOF") D EXIT X "HALT "
  1. U XWBTDEV
  1. I $G(XWBT("PCNT")) L +^XUTL("XUSYS",$J,0):99
  1. E L ;Clear Locks
  1. ;
  1. D ESND^XWBRW($C(24)_XWBERR_$C(4))
  1. I EXIT D EXIT X "HALT "
  1. S $ETRAP="Q:($ESTACK&'$QUIT) Q:$ESTACK -9 S $ECODE="""" D CLEANP^XWBTCPM G RESTART^XWBTCPM",$ECODE=",U99,"
  1. Q
  1. ;
  1. CLEANP ;Clean up the partion
  1. N XWBTDEV,XWBNULL D KILL^XUSCLEAN
  1. Q
  1. ;
  1. STYPE(X,WRAP) ;For backward compatability only
  1. I $D(WRAP) Q $$RTRNFMT^XWBLIB($G(X),WRAP)
  1. Q $$RTRNFMT^XWBLIB(X)
  1. ;
  1. BREAD(L,T) ;read tcp buffer, L is length
  1. Q $$BREAD^XWBRW(L,$G(T))
  1. ;
  1. CHPRN(N) ;change process name
  1. ;Change process name to N
  1. D SETNM^%ZOSV($E(N,1,15))
  1. Q
  1. ;
  1. SETTIME(%) ;Set the Read timeout 0=RPC, 1=sign-on
  1. ; Increased timeout period (%=1) during signon from 90 to 180 for accessibility reasons
  1. S XWBTIME=$S($G(%):180,$G(XWBVER)>1.1:$$BAT^XUPARAM,1:36000),XWBTIME(1)=5 ; (*p35)
  1. Q
  1. TIMEOUT ;Do this on MAIN loop timeout
  1. I $G(DUZ)>0 D QSND^XWBRW("#BYE#") Q
  1. ;Sign-on timeout
  1. S XWBR(0)=0,XWBR(1)=1,XWBR(2)="",XWBR(3)="TIME-OUT",XWBPTYPE=2
  1. D SND^XWBRW
  1. Q
  1. ;
  1. OS() ;Return the OS
  1. Q $S(^%ZOSF("OS")["OpenM":"OpenM",^%ZOSF("OS")["GT.M":"GT.M",^("OS")["DSM":"DSM",1:"UNK")
  1. ;
  1. INIT ;Setup
  1. S U="^",XWBTIME=10,XWBOS=$$OS,XWBDEBUG=0,XWBRBUF=""
  1. S XWBDEBUG=$$GET^XPAR("SYS","XWBDEBUG")
  1. S XWBT("BF")=$S(XWBOS="GT.M":"#",1:"!")
  1. S XWBT("PCNT")=0 I XWBOS="GT.M",$L($T(^XUSCNT)) S XWBT("PCNT")=1
  1. D LOGSTART^XWBDLOG("XWBTCPM")
  1. Q
  1. ;
  1. DEBUG ;Entry point for debug, Build a server to get the connect
  1. ;Cache sample;ZB SERV+1^XWBTCPM:"L+" ZB ETRAP+1^XWBTCPM:"B"
  1. W !,"Before running this entry point set your debugger to stop at"
  1. W !,"the place you want to debug. Some spots to use:"
  1. W !,"'SERV+1^XWBTCPM', 'MAIN+1^XWBTCPM' or 'CAPI+1^XWBPRS.'",!
  1. W !,"or location of your choice.",!
  1. W !,"IP Socket to Listen on: " R SOCK:300,! Q:'$T!(SOCK["^")
  1. ;Use %ZISTCP to do a single server
  1. D LISTEN^%ZISTCP(SOCK,"SERV^XWBTCPM")
  1. U $P W !,"Done"
  1. Q
  1. SERV ;Callback from the server
  1. S XWBTDEV=IO,XWBTIME(1)=3600 D INIT
  1. S XWBDEBUG=1,MSG=$$BREAD^XWBRW(5,60) ;R MSG#5
  1. D NEW
  1. S IO("C")=1 ;Cause the Listenr to stop
  1. Q
  1. ;
  1. EXIT ;Close out
  1. I $G(DUZ) D LOGOUT^XUSRB
  1. I $G(XWBT("PCNT")) D COUNT^XUSCNT(-1)
  1. Q
  1. ;
  1. LOG(MSG) ;Record Debug Info
  1. D:$G(XWBDEBUG) LOG^XWBDLOG(MSG)
  1. Q
  1. ;