XWBTCPC ;ISC-SF/EG/VYD - TCP/IP PROCESS HANDLER ;8/28/97 16:24
;;1.1;RPC BROKER;;Mar 28, 1997
;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:3600 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:60
. R XWBVER#$A(X):60
. R LEN#5:60
. R MSG#LEN:60
. Q
ELSE S X=$E(LEN,11,11),LEN=$E(LEN,6,10)-1 R MSG#LEN:60 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,$P(MSG,"^",4))
IF $P(MSG,"^")="TCPdebug" D
. D SNDERR W "accept",$C(4),!
C 56
Q
;
EN(XWBTIP,XWBTSKT,DUZ,XWBVER,XWBCLMAN) ; -- 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 XWBCLMAN=$G(XWBCLMAN)
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" O XWBTSKT:(TCPCHAN:ADDRESS=XWBTIP:SHARE)
;IF XWBOS="MSM"!(XWBOS="UNIX") O 56 U 56::"TCP" W /SOCKET(XWBTIP,XWBTSKT)
;IF XWBOS="OpenM" S XWBTDEV="|TCP|"_XWBTSKT O XWBTDEV:(XWBTIP:XWBTSKT:"ST":$C(13,10):512:512) ;RWF
;Use Kernel to open the connection back to the client
D CALL^%ZISTCP(XWBTIP,XWBTSKT) Q:POP S XWBTDEV=IO,IO(0)=IO
;
;setup null device "NULL"
;D OPEN^%ZISUTL("XWBNULL","NULL","0") ;Need to suppress HOME device
;S XWBNULL=IO
IF XWBOS="DSM" S XWBNULL="_NLA0:" O XWBNULL S (IO,IO(0))=XWBNULL,IOT="TRM",IOST="P-OTHER",IOST(0)=0
ELSE 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
D USE^%ZISUTL("XWBNULL"),CLOSE^%ZISUTL
Q
;
MAIN ; -- main message processing loop
F D Q:XWBTBUF="#BYE#"
. S XWBAPVER=0
. ;
. ; -- read client request
. 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:60 S L=$A(L) R XWBAPVER#L:60 R XWBTBUF#5:60
. E R XWBTBUF#4:60 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
. . 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
; -- 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=$G(XWBR) Q:I="" S 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)
. IF $D(@XWBR) K @XWBR
; -- 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
; -- 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:($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=$G(XWBR) Q:I="" S 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)
. IF $D(@XWBR) K @XWBR
; -- 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="_$$EC^%ZOSV_$C(13,10)_"LAST REF="_$$LGR^%ZOSV_$C(4)
;Turn off trapping during trap.
IF $$NEWERR^%ZTER S $ETRAP=""
E S X="",@^%ZOSF("TRAP")
U XWBTDEV
D ^%ZTER ;%ZTER clears $ZE and $ZCODE
IF XWBOS="DSM" D
. I $D(XWBTLEN),XWBTLEN,XWBERR'["SYSTEM-F" D SNDERR W XWBERR,!
IF XWBOS'="DSM" D
. D SNDERR W XWBERR,!
I (XWBERR["READERR")!(XWBERR["DISCON")!(XWBERR["SYSTEM-F") D:$G(DUZ) LOGOUT^XUSRB HALT
I '$$NEWERR^%ZTER G RESTART
S $ETRAP="Q:($ESTACK&'$QUIT) Q:$ESTACK 0 S $ECODE="""" G RESTART",$ECODE=",U99,"
Q
;
STYPE(X,WRAP) ;For backward compatability only
I $D(WRAP) Q $$RTRNFMT^XWBLIB($G(X),WRAP)
Q $$RTRNFMT^XWBLIB(X)
;
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 ;8/28/97 16:24
+1 ;;1.1;RPC BROKER;;Mar 28, 1997
+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:3600
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:60
+9 READ XWBVER#$ASCII(X):60
+10 READ LEN#5:60
+11 READ MSG#LEN:60
+12 QUIT
End DoDot:1
+13 IF '$TEST
SET X=$EXTRACT(LEN,11,11)
SET LEN=$EXTRACT(LEN,6,10)-1
READ MSG#LEN:60
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,$PIECE(MSG,"^",4))
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,XWBCLMAN) ; -- 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 XWBCLMAN=$GET(XWBCLMAN)
+7 SET XWBOS=$SELECT(^%ZOSF("OS")["DSM":"DSM",^("OS")["UNIX":"UNIX",^("OS")["OpenM":"OpenM",1:"MSM")
+8 IF $$NEWERR^%ZTER
SET $ETRAP="D ^%ZTER H"
+9 IF '$TEST
SET X="^%ZTER"
SET @^%ZOSF("TRAP")
+10 ;log response time data for DSM
KILL XRTL
IF XWBOS="DSM"
SET XRTL=1
+11 SET XWBTIME=1
+12 ;call client on new port
+13 ;IF XWBOS="DSM" O XWBTSKT:(TCPCHAN:ADDRESS=XWBTIP:SHARE)
+14 ;IF XWBOS="MSM"!(XWBOS="UNIX") O 56 U 56::"TCP" W /SOCKET(XWBTIP,XWBTSKT)
+15 ;IF XWBOS="OpenM" S XWBTDEV="|TCP|"_XWBTSKT O XWBTDEV:(XWBTIP:XWBTSKT:"ST":$C(13,10):512:512) ;RWF
+16 ;Use Kernel to open the connection back to the client
+17 DO CALL^%ZISTCP(XWBTIP,XWBTSKT)
IF POP
QUIT
SET XWBTDEV=IO
SET IO(0)=IO
+18 ;
+19 ;setup null device "NULL"
+20 ;D OPEN^%ZISUTL("XWBNULL","NULL","0") ;Need to suppress HOME device
+21 ;S XWBNULL=IO
+22 IF XWBOS="DSM"
SET XWBNULL="_NLA0:"
OPEN XWBNULL
SET (IO,IO(0))=XWBNULL
SET IOT="TRM"
SET IOST="P-OTHER"
SET IOST(0)=0
+23 IF '$TEST
SET IOP="NULL"
DO ^%ZIS
SET XWBNULL=IO
+24 ;change process name
+25 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 DO USE^%ZISUTL("XWBNULL")
DO CLOSE^%ZISUTL
+11 QUIT
+12 ;
MAIN ; -- main message processing loop
+1 FOR
Begin DoDot:1
+2 SET XWBAPVER=0
+3 ;
+4 ; -- read client request
+5 READ XWBTBUF#11:36000
IF '$TEST
SET XWBTBUF="#BYE#"
DO SNDERR
WRITE XWBTBUF,$CHAR(4),!
QUIT
+6 SET TYPE=$SELECT($EXTRACT(XWBTBUF,1,5)="{XWB}":1,1:0)
+7 IF 'TYPE
SET XWBTBUF="#BYE#"
DO SNDERR
WRITE XWBTBUF,$CHAR(4),!
QUIT
+8 SET XWBTLEN=$EXTRACT(XWBTBUF,6,10)
+9 SET L=$EXTRACT(XWBTBUF,11,11)
IF L="|"
READ L#1:60
SET L=$ASCII(L)
READ XWBAPVER#L:60
READ XWBTBUF#5:60
+10 IF '$TEST
READ XWBTBUF#4:60
SET XWBTBUF=L_XWBTBUF
+11 SET XWBPLEN=XWBTBUF
+12 READ XWBTBUF#XWBPLEN:XWBTIME
+13 IF $PIECE(XWBTBUF,U)="TCPconnect"
Begin DoDot:2
+14 ;Ack
DO SNDERR
WRITE "accept",$CHAR(4),!
End DoDot:2
QUIT
+15 IF TYPE
Begin DoDot:2
+16 KILL XWBR,XWBARY
+17 ; -- clean disconnect
IF XWBTBUF="#BYE#"
DO SNDERR
WRITE "#BYE#",$CHAR(4),!
QUIT
+18 SET XWBTLEN=XWBTLEN-15
+19 DO CALLP^XWBBRK(.XWBR,XWBTBUF)
+20 SET XWBPTYPE=$SELECT('$DATA(XWBPTYPE):1,XWBPTYPE<1:1,XWBPTYPE>6:1,1:XWBPTYPE)
End DoDot:2
+21 IF XWBTBUF="#BYE#"
QUIT
+22 USE XWBTDEV
+23 DO SNDERR
+24 ;start RTL
IF $DATA(XRTL)
DO T0^%ZOSV
+25 ;RWF
IF XWBOS="DSM"!(XWBOS="UNIX")!(XWBOS="OpenM")
DO SNDDSM
+26 IF XWBOS="MSM"
DO SND
+27 SET XWBSEC=""
+28 ;send eot and flush buffer
WRITE $CHAR(4),!
+29 ;stop RTL
IF $DATA(XRT0)
SET XRTN="RPC BROKER WRITE"
IF $DATA(XRT0)
DO T1^%ZOSV
End DoDot:1
IF XWBTBUF="#BYE#"
QUIT
+30 ;End Of Main
QUIT
+31 ;
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 ; -- single value
+6 IF XWBPTYPE=1
SET XWBR=$GET(XWBR)
WRITE XWBR
QUIT
+7 ; -- table delimited by CR+LF
+8 IF XWBPTYPE=2
Begin DoDot:1
+9 SET I=""
FOR
SET I=$ORDER(XWBR(I))
IF I=""
QUIT
WRITE XWBR(I),$CHAR(13,10)
End DoDot:1
QUIT
+10 ; -- word processing
+11 IF XWBPTYPE=3
Begin DoDot:1
+12 SET I=""
FOR
SET I=$ORDER(XWBR(I))
IF I=""
QUIT
WRITE XWBR(I)
IF XWBWRAP
WRITE $CHAR(13,10)
End DoDot:1
QUIT
+13 ; -- global array
+14 IF XWBPTYPE=4
Begin DoDot:1
+15 SET I=$GET(XWBR)
IF I=""
QUIT
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)
+16 IF $DATA(@XWBR)
KILL @XWBR
End DoDot:1
QUIT
+17 ; -- global instance
+18 IF XWBPTYPE=5
SET XWBR=$GET(@XWBR)
WRITE XWBR
QUIT
+19 ; -- variable length records
+20 IF XWBPTYPE=6
SET I=""
FOR
SET I=$ORDER(XWBR(I))
IF I=""
QUIT
WRITE $CHAR($LENGTH(XWBR(I))),XWBR(I)
+21 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 ; -- single value
+6 IF XWBPTYPE=1
SET XWBR=$GET(XWBR)
WRITE XWBR
QUIT
+7 ; -- table delimited by CR+LF
+8 IF XWBPTYPE=2
Begin DoDot:1
+9 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
+10 ; -- word processing
+11 IF XWBPTYPE=3
Begin DoDot:1
+12 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
+13 ; -- global array
+14 IF XWBPTYPE=4
Begin DoDot:1
+15 SET I=$GET(XWBR)
IF I=""
QUIT
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)
+16 IF $DATA(@XWBR)
KILL @XWBR
End DoDot:1
QUIT
+17 ; -- global instance
+18 IF XWBPTYPE=5
SET XWBR=$GET(@XWBR)
WRITE XWBR
QUIT
+19 ; -- variable length records
+20 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)
+21 QUIT
+22 ;
ETRAP ; -- on trapped error, send error info to client
+1 NEW XWBERR
+2 SET XWBERR=$CHAR(24)_"M ERROR="_$$EC^%ZOSV_$C(13,10)_"LAST REF="_$$LGR^%ZOSV_$C(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 ;%ZTER clears $ZE and $ZCODE
DO ^%ZTER
+8 IF XWBOS="DSM"
Begin DoDot:1
+9 IF $DATA(XWBTLEN)
IF XWBTLEN
IF XWBERR'["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 (XWBERR["READERR")!(XWBERR["DISCON")!(XWBERR["SYSTEM-F")
IF $GET(DUZ)
DO LOGOUT^XUSRB
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 ;
STYPE(X,WRAP) ;For backward compatability only
+1 IF $DATA(WRAP)
QUIT $$RTRNFMT^XWBLIB($GET(X),WRAP)
+2 QUIT $$RTRNFMT^XWBLIB(X)
+3 ;
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 ;
