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

XWBTCPC.m

Go to the documentation of this file.
  1. XWBTCPC ;ISC-SF/EG/VYD - TCP/IP PROCESS HANDLER ;08/25/2004 14:18
  1. ;;1.1;RPC BROKER;**2,5,4,6,9,16,26,35**;Mar 28, 1997
  1. ;Based on: XQORTCPH ;SLC/KCM - Service TCP Messages
  1. ;Modified by ISC-SF/EG
  1. ; 0. No longer supports old style OERR messages
  1. ; 1. Makes call to RPC broker
  1. ; 2. Result of an rpc call can be a closed form of global
  1. ; 3. Can receive a large local array, within limits of job
  1. ; partition size.
  1. ; 4. Sets default device to NULL device prior to call, restores
  1. ; at termination. Prevents garbage from 'talking' calls.
  1. ; 5. All reads have a timeout.
  1. ; 6. Intro message is sent when first connected.
  1. ; 7. Uses callback model to connect to client
  1. ;
  1. ;
  1. EN(XWBTIP,XWBTSKT,DUZ,XWBVER,XWBCLMAN) ; -- Main entry point
  1. N TYPE,XWBTBUF,XWBTBUF1,XWBTDEV,XWBTLEN,XWBTOS,XWBTRTN,XWBWRAP
  1. N X,XWBL,XWB1,XWB2,Y,XWBTIME,XWBPTYPE,XWBPLEN,XWBNULL,XWBODEV,XWBRBUF
  1. N XWBERROR,XWBSEC ;new error variable available to rpc calls
  1. N IO,IOP,L,XWBAPVER,VL,XWBTHDR,XWBT
  1. ;
  1. ;Set up the error trap
  1. S U="^",$ETRAP="D ^%ZTER,XUTL^XUSCLEAN H" ;XWB-30
  1. S XWBOS=$$OS
  1. S XWBT("BF")=$S(XWBOS="GT.M":"#",1:"!")
  1. ;start RUM for Broker Handler XWB*1.1*5
  1. D LOGRSRC^%ZOSV("$BROKER HANDLER$",2,1)
  1. ;
  1. S XWBCLMAN=$G(XWBCLMAN)
  1. I '$D(XWBDEBUG) D ;(*p35)
  1. . S XWBDEBUG=$$GET^XPAR("SYS","XWBDEBUG")
  1. . D LOGSTART^XWBDLOG("XWBTCPC")
  1. . Q
  1. I XWBDEBUG D LOG("Callback: "_XWBTIP_" :"_XWBTSKT) ;(*p35)
  1. D SETTIME(1) ;Setup for sign-on time-out
  1. ;Use Kernel to open the connection back to the client on new port
  1. D CALL^%ZISTCP(XWBTIP,XWBTSKT) Q:POP S XWBTDEV=IO,IO(0)=IO
  1. ;Attempt to share the license, Must have TCP port open first.
  1. U XWBTDEV I $T(SHARELIC^%ZOSV)'="" 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 ^%ZTER Q
  1. D SAVDEV^%ZISUTL("XWBNULL")
  1. I XWBOS="GTM" S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""")
  1. ;change process name
  1. S X="ip"_$P(XWBTIP,".",3,4)_":"_XWBTSKT
  1. D SETNM^%ZOSV($E(X,1,15)),LOG("ProcName: "_X)
  1. RESTART ;(*p35)
  1. N $ESTACK S $ETRAP="D ETRAP^XWBTCPC"
  1. S U="^",DUZ=0,DUZ(0)="",DTIME=300
  1. U XWBTDEV D MAIN
  1. ;Turn off the error trap for the exit
  1. S $ETRAP=""
  1. I $G(DUZ) D LOGOUT^XUSRB
  1. K XWBR,XWBARY
  1. ;stop RUM for handler XWB*1.1*5
  1. D LOGRSRC^%ZOSV("$BROKER HANDLER$",2,2)
  1. D LOG("DUZ="_$G(DUZ)_" LOGGED OFF")
  1. D USE^%ZISUTL("XWBNULL"),CLOSE^%ZISUTL("XWBNULL")
  1. C XWBTDEV ;Close can get an error
  1. Q
  1. ;
  1. MAIN ; -- main message processing loop
  1. N XCNT,XR
  1. F D Q:XWBTBUF="#BYE#"
  1. . S XWBAPVER=0,(XWBSEC,XWBERROR,XWBRBUF)=""
  1. . U XWBTDEV ;Make sure we are reading from the right device
  1. . ; -- read client request
  1. . ;F XCNT=0:0 R XR#1:XWBTIME Q:(XR="{")!(XR="#") I '$T S XCNT=XCNT+1 Q:XCNT>5
  1. . S XR=$$BREAD^XWBRW(1,XWBTIME,1)
  1. . I '$L(XR) D LOG("Timeout"),TIMEOUT S XWBTBUF="#BYE#" Q
  1. . S XWBTHDR=XR_$$BREAD^XWBRW(4) ;(*p35)
  1. . I XWBTHDR["#BYE#" S XWBTBUF="#BYE#" Q ;Clear $C(4)
  1. . S XWBTHDR=XWBTHDR_$$BREAD^XWBRW(6)
  1. . I $G(XWBDEBUG)>1 D LOG("HDR Read:"_XWBTHDR_":")
  1. . S TYPE=($E(XWBTHDR,1,5)="{XWB}") ;check HDR
  1. . I 'TYPE D Q
  1. . . D LOG("Bad Header: "_XWBTHDR) ;(*p35)
  1. . . S XWBTBUF="#BYE#" D QSND^XWBRW(XWBTBUF) ;(*p35)
  1. . . Q
  1. . S XWBTLEN=$E(XWBTHDR,6,10),L=$E(XWBTHDR,11)
  1. . I L="|" D ;(*p35) Save $T
  1. . . S VL=$$BREAD^XWBRW(1),VL=$A(VL)
  1. . . S XWBAPVER=$$BREAD^XWBRW(VL),XWBPLEN=$$BREAD^XWBRW(5) ;(*p35)
  1. . E S XWBTBUF=$$BREAD^XWBRW(4),XWBPLEN=L_XWBTBUF ;(*p35)
  1. . S XWBTBUF=$$BREAD^XWBRW(XWBPLEN) ;(*p35)
  1. . I $P(XWBTBUF,U)="TCPconnect" D Q
  1. . . D QSND^XWBRW("accept") ;Ack (*p35)
  1. . IF TYPE D
  1. . . K XWBR,XWBARY
  1. . . IF XWBTBUF="#BYE#" D QSND^XWBRW("#BYE#") Q ; -- clean disconnect
  1. . . S XWBTLEN=XWBTLEN-15
  1. . . D CALLP^XWBBRK(.XWBR,XWBTBUF)
  1. . . S XWBPTYPE=$S('$D(XWBPTYPE):1,XWBPTYPE<1:1,XWBPTYPE>6:1,1:XWBPTYPE)
  1. . IF XWBTBUF="#BYE#" D LOG("APP set #BYE#") Q ;(*p35)
  1. . U XWBTDEV
  1. . D SND^XWBRW ;Does SNDERR,SND,WRITE($C(4))
  1. . I $G(XWBSHARE) D KILL1^XUSCLEAN ; CLEAN OUT PARTITION FOR SHARED BROKER
  1. Q ;End Of Main
  1. ;
  1. ETRAP ; -- on trapped error, send error info to client
  1. N XWBERC,XWBERR
  1. ;Change trapping during trap.
  1. S $ETRAP="D ^%ZTER,BYE^XUSCLEAN,XUTL^XUSCLEAN HALT" ;XWB-30
  1. S XWBERC=$E($$EC^%ZOSV,1,200),XWBERR="M ERROR="_XWBERC_$C(13,10)_"LAST REF="_$$LGR^%ZOSV
  1. S XWBOS=$$OS
  1. ;Check for short read, Tell Client to resend.
  1. I $EC["U411" S XWBERROR="U411",XWBSEC="",XWBERR="Data Transfer Error to Server"
  1. D ^%ZTER ;%ZTER clears $ZE and $ECODE
  1. I $G(XWBDEBUG) D LOG("In ETRAP: "_XWBERC) ;(*p35)
  1. I ($G(XWBERC)["READ")!($G(XWBERC)["WRITE")!($G(XWBERC)["SYSTEM-F")!('$D(XWBERC)) D:$G(DUZ) LOGOUT^XUSRB HALT ; XWB-30
  1. U XWBTDEV
  1. L ;Clear locks (*p35)
  1. ETX ;Exit for trap
  1. D ESND^XWBRW($C(24)_XWBERR_$C(4)) ;(p*35)
  1. S $ETRAP="Q:($ESTACK&'$QUIT) Q:$ESTACK -9 S $ECODE="""" G RESTART^XWBTCPC",$ECODE=",U99,"
  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. 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.105:$$BAT^XUPARAM,1:36000),XWBTIME(1)=5 ; (*p35)
  1. I $G(%) S XWBTIME=$S($G(XWBVER)>1.1:90,1:36000)
  1. Q
  1. TIMEOUT ;Do this on MAIN loop timeout
  1. I $G(DUZ)>0 D QSND^XWBRW("#BYE#"_$C(4)) 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. MSM ;entry point for MSERVER service - used by MSM
  1. N XWBVER,LEN,MSG,X
  1. S XWBVER=0
  1. R LEN#11:3600 IF $E(LEN,1,5)'="{XWB}" D Q ;bad client, abort
  1. . W "RPC broker disconnect!",!
  1. . C 56
  1. . Q
  1. IF $E(LEN,11,11)="|" D
  1. . R X#1:60
  1. . R XWBVER#$A(X):60
  1. . R LEN#5:60
  1. . R MSG#LEN:60
  1. . Q
  1. ELSE S X=$E(LEN,11,11),LEN=$E(LEN,6,10)-1 R MSG#LEN:60 S MSG=X_MSG
  1. IF $P(MSG,"^")="TCPconnect" D
  1. . D QSND^XWBRW("accept")
  1. . C 56
  1. . D EN($P(MSG,"^",2),$P(MSG,"^",3),$P(X,"^"),XWBVER,$P(MSG,"^",4))
  1. IF $P(MSG,"^")="TCPdebug" D
  1. . D QSND^XWBRW("accept")
  1. C 56
  1. Q
  1. OS() ;Return the OS
  1. N % S %=^%ZOSF("OS") ;(*p35)
  1. Q $S(%["DSM":"DSM",%["OpenM":"OpenM",%["GT.M":"GTM",1:"MSM") ;(*p35)
  1. ;
  1. LOG(TX) ;DeBug Logging (*p35)
  1. D:$G(XWBDEBUG) LOG^XWBDLOG(TX)
  1. Q