XWBCDDD.m

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       ;