XWBTCPC ;ISC-SF/EG/VYD - TCP/IP PROCESS HANDLER ;11/19/96 14:01 [ 11/20/96 12:53 PM ]
;;1.1T3;RPC BROKER;;Nov 25, 1996
;Based on:
;XQORTCPH ;SLC/KCM - Service TCP Messages [ 12/04/94 9:06 PM ]
;Modified by ISC-SF/EG
; 0. No longer supports old style OERR messages
; 1. Makes call to RPC broker
; 2. Handles MSM Server under Windows NT
; 3. Handles MSM under Unix - same as DSM
; 4. Result of an rpc call can be a closed form of global
; 5. Can receive a large local array, within limits of job
; partition size.
; 6. Sets default device to NULL device prior to call, restores
; at termination. Prevents garbage from 'talking' calls.
; 7. All reads have a timeout.
; 8. Intro message is sent when first connected.
; 9. Uses callback model to connect to client
;
MSM ;entry point for MSERVER service - used by MSM
N XWBVER,LEN,MSG,X
S XWBVER=0
R LEN#11 IF $E(LEN,1,5)'="{XWB}" D Q ;bad client, abort
. W "RPC broker disconnect!",!
. C 56
. Q
IF $E(LEN,11,11)="|" D
. R X#1
. R XWBVER#$A(X)
. R LEN#5
. R MSG#LEN
. Q
ELSE S X=$E(LEN,11,11),LEN=$E(LEN,6,10)-1 R MSG#LEN S MSG=X_MSG
IF $P(MSG,"^")="TCPconnect" D
. D SNDERR W "accept",$C(4),!
. C 56
. D EN($P(MSG,"^",2),$P(MSG,"^",3),$P(X,"^"),XWBVER)
IF $P(MSG,"^")="TCPdebug" D
. D SNDERR W "accept",$C(4),!
C 56
Q
;
EN(XWBTIP,XWBTSKT,DUZ,XWBVER) ; -- Main entry point
N TYPE,XWBTBUF,XWBTBUF1,XWBTDEV,XWBTLEN,XWBTOS,XWBTRTN,XWBWRAP
N X,XWBL,XWB1,XWB2,Y,XWBTIME,XWBPTYPE,XWBPLEN,XWBNULL,XWBODEV
N XWBERROR,XWBSEC ;new error variable available to rpc calls
N XRTL,IO,IOP,L,XWBAPVER
;
S XWBOS=$S(^%ZOSF("OS")["DSM":"DSM",^("OS")["UNIX":"UNIX",^("OS")["OpenM":"OpenM",1:"MSM")
IF $$NEWERR^%ZTER S $ETRAP="D ^%ZTER H"
E S X="^%ZTER",@^%ZOSF("TRAP")
K XRTL IF XWBOS="DSM" S XRTL=1 ;log response time data for DSM
S XWBTIME=1
;call client on new port
IF XWBOS="DSM" D
. ;IF '$D(%)#2 S %=$P($ZIO,":")_":" ; Call with dsm$xecute()
. ;S %=+$P($ZIO,"Port: ",2)_":"
. ;S (XWBTDEV,IO,IO(0))=%,X=$E(%_"WKSTA",1,15)
. ;;D SETENV^%ZOSV
. O XWBTSKT:(TCPCHAN:ADDRESS=XWBTIP:SHARE)
. U XWBTSKT X ^%ZOSF("TRMOFF")
. S XWBTDEV=XWBTSKT
;
IF XWBOS="MSM"!(XWBOS="UNIX") D
. O 56 U 56::"TCP"
. W /SOCKET(XWBTIP,XWBTSKT)
. ;S (XWBTDEV,IO,IO(0))=56
. S XWBTDEV=56
;
;Open in stream mode, Standard terminators, Big buffers
IF XWBOS="OpenM" D
. S XWBTDEV="|TCP|"_XWBTSKT
. O XWBTDEV:(XWBTIP:XWBTSKT:"ST":$C(13,10):512:512) ;RWF
. U XWBTDEV ;RWF
;
;setup null device "NULL"
S XWBNULL=$S(XWBOS="DSM":"_NLA0:",1:"")
IF XWBOS="DSM" O XWBNULL
ELSE D
. S (IO,IO(0))=XWBTDEV
. S IOP="NULL" D ^%ZIS S XWBNULL=IO
;
;change process name
D CHPRN("ip"_$P(XWBTIP,".",3,4)_":"_XWBTSKT)
RESTART IF $$NEWERR^%ZTER N $ESTACK S $ETRAP="S %ZTER11S=$STACK D ETRAP^XWBTCPC"
E S X="ETRAP^XWBTCPC",@^%ZOSF("TRAP")
S DIQUIET=1,U="^" D DT^DICRW
U XWBTDEV D MAIN
;Turn off the error for the exit
IF $$NEWERR^%ZTER S $ETRAP=""
E S X="",@^%ZOSF("TRAP")
I $G(DUZ) D LOGOUT^XUSRB
K XWBR,XWBARY
C XWBTDEV
IF XWBOS="DSM" C XWBNULL
ELSE D ^%ZISC
Q
;
MAIN ; -- main message processing loop
F D Q:XWBTBUF="#BYE#"
. S XWBAPVER=0
. ;
. ; -- read client request
. ;R XWBTBUF#15:36000 IF '$T S XWBTBUF="#BYE#" D SNDERR W XWBTBUF,$C(4),! Q
. R XWBTBUF#11:36000 IF '$T S XWBTBUF="#BYE#" D SNDERR W XWBTBUF,$C(4),! Q
. S TYPE=$S($E(XWBTBUF,1,5)="{XWB}":1,1:0)
. I 'TYPE S XWBTBUF="#BYE#" D SNDERR W XWBTBUF,$C(4),! Q
. S XWBTLEN=$E(XWBTBUF,6,10)
. S L=$E(XWBTBUF,11,11) IF L="|" R L#1 S L=$A(L) R XWBAPVER#L R XWBTBUF#5
. E R XWBTBUF#4 S XWBTBUF=L_XWBTBUF
. S XWBPLEN=XWBTBUF
. R XWBTBUF#XWBPLEN:XWBTIME
. I $P(XWBTBUF,U)="TCPconnect" D Q
. . D SNDERR W "accept",$C(4),! ;Ack
. IF TYPE D
. . K XWBR,XWBARY
. . IF XWBTBUF="#BYE#" D SNDERR W "#BYE#",$C(4),! Q ; -- clean disconnect
. . S XWBTLEN=XWBTLEN-15
. . ;IF XWBOS="DSM" X "ZDEBUG ON B "
. . D CALLP^XWBBRK(.XWBR,XWBTBUF)
. . S XWBPTYPE=$S('$D(XWBPTYPE):1,XWBPTYPE<1:1,XWBPTYPE>6:1,1:XWBPTYPE)
. IF XWBTBUF="#BYE#" Q
. U XWBTDEV
. D SNDERR
. D:$D(XRTL) T0^%ZOSV ;start RTL
. IF XWBOS="DSM"!(XWBOS="UNIX")!(XWBOS="OpenM") D SNDDSM ;RWF
. IF XWBOS="MSM" D SND
. S XWBSEC=""
. W $C(4),! ;send eot and flush buffer
. S:$D(XRT0) XRTN="RPC BROKER WRITE" D:$D(XRT0) T1^%ZOSV ;stop RTL
Q ;End Of Main
;
SNDERR ;send error information
;XWBSEC is the security packet, XWBERROR is application packet
N X
S X=$G(XWBSEC)
W $C($L(X))_X W:($X+$L(X)+1)>512 !
S X=$G(XWBERROR)
W $C($L(X))_X W:($X+$L(X)+1)>512 !
S XWBERROR="" ;clears parameters
Q
;
SND ; -- Send data (all except DSM)
N I,T
;
; -- error or abort occurred, send null
IF $L(XWBSEC)>0 W "" Q
; -- RPC returned closed root of array, process it as global array
IF XWBPTYPE=2,$D(XWBR)#2,$D(@XWBR)>1 S XWBPTYPE=4,XWBWRAP=1
; -- single value
IF XWBPTYPE=1 S XWBR=$G(XWBR) W XWBR Q
; -- table delimited by CR+LF
IF XWBPTYPE=2 D Q
. S I="" F S I=$O(XWBR(I)) Q:I="" W XWBR(I),$C(13,10)
; -- word processing
IF XWBPTYPE=3 D Q
. S I="" F S I=$O(XWBR(I)) Q:I="" W XWBR(I) W:XWBWRAP $C(13,10)
; -- global array
IF XWBPTYPE=4 D Q
. S I=XWBR,T=$E(I,1,$L(I)-1) W:$D(@I)>10 @I F S I=$Q(@I) Q:I=""!(I'[T) W @I W:XWBWRAP $C(13,10)
; -- global instance
IF XWBPTYPE=5 S XWBR=$G(@XWBR) W XWBR Q
; -- variable length records
IF XWBPTYPE=6 S I="" F S I=$O(XWBR(I)) Q:I="" W $C($L(XWBR(I))),XWBR(I)
Q
SNDDSM ; -- send data for DSM (requires buffer flush (!) every 509 chars)
N I,T
;
; -- error or abort occurred, send null
IF $L(XWBSEC)>0 W "" Q
; -- RPC returned closed root of array, process it as global array
IF XWBPTYPE=2,$D(XWBR)#2,$D(@XWBR)>1 S XWBPTYPE=4,XWBWRAP=1
; -- single value
IF XWBPTYPE=1 S XWBR=$G(XWBR) W XWBR Q
; -- table delimited by CR+LF
I XWBPTYPE=2 D Q
. S I="" F S I=$O(XWBR(I)) Q:I="" W:($X+$L(XWBR(I)))>509 ! W XWBR(I),$C(13,10)
; -- word processing
IF XWBPTYPE=3 D Q
. S I="" F S I=$O(XWBR(I)) Q:I="" W:($X+$L(XWBR(I)))>509 ! W XWBR(I) W:XWBWRAP $C(13,10)
; -- global array
IF XWBPTYPE=4 D Q
. S I=XWBR,T=$E(I,1,$L(I)-1) W:$D(@I)>10 @I F S I=$Q(@I) Q:I=""!(I'[T) W:($X+$L(@I))>509 ! W @I W:XWBWRAP&(@I'=$C(13,10)) $C(13,10)
; -- global instance
IF XWBPTYPE=5 S XWBR=$G(@XWBR) W XWBR Q
; -- variable length records
IF XWBPTYPE=6 S I="" F S I=$O(XWBR(I)) Q:I="" W:($X+$L(XWBR(I)))>509 ! W $C($L(XWBR(I))),XWBR(I)
Q
;
ETRAP ; -- on trapped error, send error info to client
N XWBERR
S XWBERR=$C(24)_"M ERROR="_$ZERROR_$C(13,10)_"LAST REF="_$ZR_$C(4)
;Turn off trapping during trap.
IF $$NEWERR^%ZTER S $ETRAP=""
E S X="",@^%ZOSF("TRAP")
U XWBTDEV
D ^%ZTER
IF XWBOS="DSM" D
. I $D(XWBTLEN),XWBTLEN,$ZE'["SYSTEM-F" D SNDERR W XWBERR,!
IF XWBOS'="DSM" D
. D SNDERR W XWBERR,!
I ($ZE["READERR")!($ZE["DISCON")!($ZE["SYSTEM-F") HALT
I '$$NEWERR^%ZTER G RESTART
S $ETRAP="Q:($ESTACK&'$QUIT) Q:$ESTACK 0 S $ECODE="""" G RESTART",$ECODE=",U99,"
Q
;
BREAD(L) ;read tcp buffer, L is length
N E,X,DONE
S (E,DONE)=0
R X#L:XWBTIME
S E=X
IF $L(E)<L F D Q:'DONE
. IF $L(E)=L S DONE=1 Q
. R X#(L-$L(E)):XWBTIME
. S E=E_X
Q E
;
CHPRN(N) ;change process name
;Change process name to N
D SETNM^%ZOSV($E(N,1,15))
Q
;
XWBTCPC ;ISC-SF/EG/VYD - TCP/IP PROCESS HANDLER ;11/19/96 14:01 [ 11/20/96 12:53 PM ]
+1 ;;1.1T3;RPC BROKER;;Nov 25, 1996
+2 ;Based on:
+3 ;XQORTCPH ;SLC/KCM - Service TCP Messages [ 12/04/94 9:06 PM ]
+4 ;Modified by ISC-SF/EG
+5 ; 0. No longer supports old style OERR messages
+6 ; 1. Makes call to RPC broker
+7 ; 2. Handles MSM Server under Windows NT
+8 ; 3. Handles MSM under Unix - same as DSM
+9 ; 4. Result of an rpc call can be a closed form of global
+10 ; 5. Can receive a large local array, within limits of job
+11 ; partition size.
+12 ; 6. Sets default device to NULL device prior to call, restores
+13 ; at termination. Prevents garbage from 'talking' calls.
+14 ; 7. All reads have a timeout.
+15 ; 8. Intro message is sent when first connected.
+16 ; 9. Uses callback model to connect to client
+17 ;
MSM ;entry point for MSERVER service - used by MSM
+1 NEW XWBVER,LEN,MSG,X
+2 SET XWBVER=0
+3 ;bad client, abort
READ LEN#11
IF $EXTRACT(LEN,1,5)'="{XWB}"
Begin DoDot:1
+4 WRITE "RPC broker disconnect!",!
+5 CLOSE 56
+6 QUIT
End DoDot:1
QUIT
+7 IF $EXTRACT(LEN,11,11)="|"
Begin DoDot:1
+8 READ X#1
+9 READ XWBVER#$ASCII(X)
+10 READ LEN#5
+11 READ MSG#LEN
+12 QUIT
End DoDot:1
+13 IF '$TEST
SET X=$EXTRACT(LEN,11,11)
SET LEN=$EXTRACT(LEN,6,10)-1
READ MSG#LEN
SET MSG=X_MSG
+14 IF $PIECE(MSG,"^")="TCPconnect"
Begin DoDot:1
+15 DO SNDERR
WRITE "accept",$CHAR(4),!
+16 CLOSE 56
+17 DO EN($PIECE(MSG,"^",2),$PIECE(MSG,"^",3),$PIECE(X,"^"),XWBVER)
End DoDot:1
+18 IF $PIECE(MSG,"^")="TCPdebug"
Begin DoDot:1
+19 DO SNDERR
WRITE "accept",$CHAR(4),!
End DoDot:1
+20 CLOSE 56
+21 QUIT
+22 ;
EN(XWBTIP,XWBTSKT,DUZ,XWBVER) ; -- Main entry point
+1 NEW TYPE,XWBTBUF,XWBTBUF1,XWBTDEV,XWBTLEN,XWBTOS,XWBTRTN,XWBWRAP
+2 NEW X,XWBL,XWB1,XWB2,Y,XWBTIME,XWBPTYPE,XWBPLEN,XWBNULL,XWBODEV
+3 ;new error variable available to rpc calls
NEW XWBERROR,XWBSEC
+4 NEW XRTL,IO,IOP,L,XWBAPVER
+5 ;
+6 SET XWBOS=$SELECT(^%ZOSF("OS")["DSM":"DSM",^("OS")["UNIX":"UNIX",^("OS")["OpenM":"OpenM",1:"MSM")
+7 IF $$NEWERR^%ZTER
SET $ETRAP="D ^%ZTER H"
+8 IF '$TEST
SET X="^%ZTER"
SET @^%ZOSF("TRAP")
+9 ;log response time data for DSM
KILL XRTL
IF XWBOS="DSM"
SET XRTL=1
+10 SET XWBTIME=1
+11 ;call client on new port
+12 IF XWBOS="DSM"
Begin DoDot:1
+13 ;IF '$D(%)#2 S %=$P($ZIO,":")_":" ; Call with dsm$xecute()
+14 ;S %=+$P($ZIO,"Port: ",2)_":"
+15 ;S (XWBTDEV,IO,IO(0))=%,X=$E(%_"WKSTA",1,15)
+16 ;;D SETENV^%ZOSV
+17 OPEN XWBTSKT:(TCPCHAN:ADDRESS=XWBTIP:SHARE)
+18 USE XWBTSKT
XECUTE ^%ZOSF("TRMOFF")
+19 SET XWBTDEV=XWBTSKT
End DoDot:1
+20 ;
+21 IF XWBOS="MSM"!(XWBOS="UNIX")
Begin DoDot:1
+22 OPEN 56
USE 56::"TCP"
+23 WRITE /SOCKET(XWBTIP,XWBTSKT)
+24 ;S (XWBTDEV,IO,IO(0))=56
+25 SET XWBTDEV=56
End DoDot:1
+26 ;
+27 ;Open in stream mode, Standard terminators, Big buffers
+28 IF XWBOS="OpenM"
Begin DoDot:1
+29 SET XWBTDEV="|TCP|"_XWBTSKT
+30 ;RWF
OPEN XWBTDEV:(XWBTIP:XWBTSKT:"ST":$CHAR(13,10):512:512)
+31 ;RWF
USE XWBTDEV
End DoDot:1
+32 ;
+33 ;setup null device "NULL"
+34 SET XWBNULL=$SELECT(XWBOS="DSM":"_NLA0:",1:"")
+35 IF XWBOS="DSM"
OPEN XWBNULL
+36 IF '$TEST
Begin DoDot:1
+37 SET (IO,IO(0))=XWBTDEV
+38 SET IOP="NULL"
DO ^%ZIS
SET XWBNULL=IO
End DoDot:1
+39 ;
+40 ;change process name
+41 DO CHPRN("ip"_$PIECE(XWBTIP,".",3,4)_":"_XWBTSKT)
RESTART IF $$NEWERR^%ZTER
NEW $ESTACK
SET $ETRAP="S %ZTER11S=$STACK D ETRAP^XWBTCPC"
+1 IF '$TEST
SET X="ETRAP^XWBTCPC"
SET @^%ZOSF("TRAP")
+2 SET DIQUIET=1
SET U="^"
DO DT^DICRW
+3 USE XWBTDEV
DO MAIN
+4 ;Turn off the error for the exit
+5 IF $$NEWERR^%ZTER
SET $ETRAP=""
+6 IF '$TEST
SET X=""
SET @^%ZOSF("TRAP")
+7 IF $GET(DUZ)
DO LOGOUT^XUSRB
+8 KILL XWBR,XWBARY
+9 CLOSE XWBTDEV
+10 IF XWBOS="DSM"
CLOSE XWBNULL
+11 IF '$TEST
DO ^%ZISC
+12 QUIT
+13 ;
MAIN ; -- main message processing loop
+1 FOR
Begin DoDot:1
+2 SET XWBAPVER=0
+3 ;
+4 ; -- read client request
+5 ;R XWBTBUF#15:36000 IF '$T S XWBTBUF="#BYE#" D SNDERR W XWBTBUF,$C(4),! Q
+6 READ XWBTBUF#11:36000
IF '$TEST
SET XWBTBUF="#BYE#"
DO SNDERR
WRITE XWBTBUF,$CHAR(4),!
QUIT
+7 SET TYPE=$SELECT($EXTRACT(XWBTBUF,1,5)="{XWB}":1,1:0)
+8 IF 'TYPE
SET XWBTBUF="#BYE#"
DO SNDERR
WRITE XWBTBUF,$CHAR(4),!
QUIT
+9 SET XWBTLEN=$EXTRACT(XWBTBUF,6,10)
+10 SET L=$EXTRACT(XWBTBUF,11,11)
IF L="|"
READ L#1
SET L=$ASCII(L)
READ XWBAPVER#L
READ XWBTBUF#5
+11 IF '$TEST
READ XWBTBUF#4
SET XWBTBUF=L_XWBTBUF
+12 SET XWBPLEN=XWBTBUF
+13 READ XWBTBUF#XWBPLEN:XWBTIME
+14 IF $PIECE(XWBTBUF,U)="TCPconnect"
Begin DoDot:2
+15 ;Ack
DO SNDERR
WRITE "accept",$CHAR(4),!
End DoDot:2
QUIT
+16 IF TYPE
Begin DoDot:2
+17 KILL XWBR,XWBARY
+18 ; -- clean disconnect
IF XWBTBUF="#BYE#"
DO SNDERR
WRITE "#BYE#",$CHAR(4),!
QUIT
+19 SET XWBTLEN=XWBTLEN-15
+20 ;IF XWBOS="DSM" X "ZDEBUG ON B "
+21 DO CALLP^XWBBRK(.XWBR,XWBTBUF)
+22 SET XWBPTYPE=$SELECT('$DATA(XWBPTYPE):1,XWBPTYPE<1:1,XWBPTYPE>6:1,1:XWBPTYPE)
End DoDot:2
+23 IF XWBTBUF="#BYE#"
QUIT
+24 USE XWBTDEV
+25 DO SNDERR
+26 ;start RTL
IF $DATA(XRTL)
DO T0^%ZOSV
+27 ;RWF
IF XWBOS="DSM"!(XWBOS="UNIX")!(XWBOS="OpenM")
DO SNDDSM
+28 IF XWBOS="MSM"
DO SND
+29 SET XWBSEC=""
+30 ;send eot and flush buffer
WRITE $CHAR(4),!
+31 ;stop RTL
IF $DATA(XRT0)
SET XRTN="RPC BROKER WRITE"
IF $DATA(XRT0)
DO T1^%ZOSV
End DoDot:1
IF XWBTBUF="#BYE#"
QUIT
+32 ;End Of Main
QUIT
+33 ;
SNDERR ;send error information
+1 ;XWBSEC is the security packet, XWBERROR is application packet
+2 NEW X
+3 SET X=$GET(XWBSEC)
+4 WRITE $CHAR($LENGTH(X))_X
IF ($X+$LENGTH(X)+1)>512
WRITE !
+5 SET X=$GET(XWBERROR)
+6 WRITE $CHAR($LENGTH(X))_X
IF ($X+$LENGTH(X)+1)>512
WRITE !
+7 ;clears parameters
SET XWBERROR=""
+8 QUIT
+9 ;
SND ; -- Send data (all except DSM)
+1 NEW I,T
+2 ;
+3 ; -- error or abort occurred, send null
+4 IF $LENGTH(XWBSEC)>0
WRITE ""
QUIT
+5 ; -- RPC returned closed root of array, process it as global array
+6 IF XWBPTYPE=2
IF $DATA(XWBR)#2
IF $DATA(@XWBR)>1
SET XWBPTYPE=4
SET XWBWRAP=1
+7 ; -- single value
+8 IF XWBPTYPE=1
SET XWBR=$GET(XWBR)
WRITE XWBR
QUIT
+9 ; -- table delimited by CR+LF
+10 IF XWBPTYPE=2
Begin DoDot:1
+11 SET I=""
FOR
SET I=$ORDER(XWBR(I))
IF I=""
QUIT
WRITE XWBR(I),$CHAR(13,10)
End DoDot:1
QUIT
+12 ; -- word processing
+13 IF XWBPTYPE=3
Begin DoDot:1
+14 SET I=""
FOR
SET I=$ORDER(XWBR(I))
IF I=""
QUIT
WRITE XWBR(I)
IF XWBWRAP
WRITE $CHAR(13,10)
End DoDot:1
QUIT
+15 ; -- global array
+16 IF XWBPTYPE=4
Begin DoDot:1
+17 SET I=XWBR
SET T=$EXTRACT(I,1,$LENGTH(I)-1)
IF $DATA(@I)>10
WRITE @I
FOR
SET I=$QUERY(@I)
IF I=""!(I'[T)
QUIT
WRITE @I
IF XWBWRAP
WRITE $CHAR(13,10)
End DoDot:1
QUIT
+18 ; -- global instance
+19 IF XWBPTYPE=5
SET XWBR=$GET(@XWBR)
WRITE XWBR
QUIT
+20 ; -- variable length records
+21 IF XWBPTYPE=6
SET I=""
FOR
SET I=$ORDER(XWBR(I))
IF I=""
QUIT
WRITE $CHAR($LENGTH(XWBR(I))),XWBR(I)
+22 QUIT
SNDDSM ; -- send data for DSM (requires buffer flush (!) every 509 chars)
+1 NEW I,T
+2 ;
+3 ; -- error or abort occurred, send null
+4 IF $LENGTH(XWBSEC)>0
WRITE ""
QUIT
+5 ; -- RPC returned closed root of array, process it as global array
+6 IF XWBPTYPE=2
IF $DATA(XWBR)#2
IF $DATA(@XWBR)>1
SET XWBPTYPE=4
SET XWBWRAP=1
+7 ; -- single value
+8 IF XWBPTYPE=1
SET XWBR=$GET(XWBR)
WRITE XWBR
QUIT
+9 ; -- table delimited by CR+LF
+10 IF XWBPTYPE=2
Begin DoDot:1
+11 SET I=""
FOR
SET I=$ORDER(XWBR(I))
IF I=""
QUIT
IF ($X+$LENGTH(XWBR(I)))>509
WRITE !
WRITE XWBR(I),$CHAR(13,10)
End DoDot:1
QUIT
+12 ; -- word processing
+13 IF XWBPTYPE=3
Begin DoDot:1
+14 SET I=""
FOR
SET I=$ORDER(XWBR(I))
IF I=""
QUIT
IF ($X+$LENGTH(XWBR(I)))>509
WRITE !
WRITE XWBR(I)
IF XWBWRAP
WRITE $CHAR(13,10)
End DoDot:1
QUIT
+15 ; -- global array
+16 IF XWBPTYPE=4
Begin DoDot:1
+17 SET I=XWBR
SET T=$EXTRACT(I,1,$LENGTH(I)-1)
IF $DATA(@I)>10
WRITE @I
FOR
SET I=$QUERY(@I)
IF I=""!(I'[T)
QUIT
IF ($X+$LENGTH(@I))>509
WRITE !
WRITE @I
IF XWBWRAP&(@I'=$CHAR(13,10))
WRITE $CHAR(13,10)
End DoDot:1
QUIT
+18 ; -- global instance
+19 IF XWBPTYPE=5
SET XWBR=$GET(@XWBR)
WRITE XWBR
QUIT
+20 ; -- variable length records
+21 IF XWBPTYPE=6
SET I=""
FOR
SET I=$ORDER(XWBR(I))
IF I=""
QUIT
IF ($X+$LENGTH(XWBR(I)))>509
WRITE !
WRITE $CHAR($LENGTH(XWBR(I))),XWBR(I)
+22 QUIT
+23 ;
ETRAP ; -- on trapped error, send error info to client
+1 NEW XWBERR
+2 SET XWBERR=$CHAR(24)_"M ERROR="_$ZERROR_$CHAR(13,10)_"LAST REF="_$ZR_$CHAR(4)
+3 ;Turn off trapping during trap.
+4 IF $$NEWERR^%ZTER
SET $ETRAP=""
+5 IF '$TEST
SET X=""
SET @^%ZOSF("TRAP")
+6 USE XWBTDEV
+7 DO ^%ZTER
+8 IF XWBOS="DSM"
Begin DoDot:1
+9 IF $DATA(XWBTLEN)
IF XWBTLEN
IF $ZE'["SYSTEM-F"
DO SNDERR
WRITE XWBERR,!
End DoDot:1
+10 IF XWBOS'="DSM"
Begin DoDot:1
+11 DO SNDERR
WRITE XWBERR,!
End DoDot:1
+12 IF ($ZE["READERR")!($ZE["DISCON")!($ZE["SYSTEM-F")
HALT
+13 IF '$$NEWERR^%ZTER
GOTO RESTART
+14 SET $ETRAP="Q:($ESTACK&'$QUIT) Q:$ESTACK 0 S $ECODE="""" G RESTART"
SET $ECODE=",U99,"
+15 QUIT
+16 ;
BREAD(L) ;read tcp buffer, L is length
+1 NEW E,X,DONE
+2 SET (E,DONE)=0
+3 READ X#L:XWBTIME
+4 SET E=X
+5 IF $LENGTH(E)<L
FOR
Begin DoDot:1
+6 IF $LENGTH(E)=L
SET DONE=1
QUIT
+7 READ X#(L-$LENGTH(E)):XWBTIME
+8 SET E=E_X
End DoDot:1
IF 'DONE
QUIT
+9 QUIT E
+10 ;
CHPRN(N) ;change process name
+1 ;Change process name to N
+2 DO SETNM^%ZOSV($EXTRACT(N,1,15))
+3 QUIT
+4 ;
