XWBCSAV.m

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       ;