XWBTCPH ;ISC-SF/EG - TCP/IP PROCESS HANDLER ; 4/28/95
;;1.0T11;RPC BROKER;;Oct 31, 1995
;;V1.0T10;KERNEL RPC BROKER;
;Based on:
;XQORTCPH ;SLC/KCM - Service TCP Messages [ 12/04/94 9:06 PM ]
;XWBTCPH ;XXX/KCMO converted to use UCX service; 4/28/95
;
;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.
;
EN ; -- Main entry point for the UCX service call
N TYPE,XWBTBUF,XWBTBUF1,XWBTDEV,XWBTLEN,XWBTOS,XWBTRTN,XWBWRAP
N X,XWBL,XWB1,XWB2,Y,XWBTIME,XWBPTYPE,XWBPLEN,XWBNULL,XWBODEV
S XWBTIME=1
S XWBOS=$S(^%ZOSF("OS")["DSM":"DSM",^("OS")["UNIX":"UNIX",1:"MSM")
S XWBNULL=$S(XWBOS="DSM":"NLA0:",1:"")
IF XWBOS="DSM" D
. IF '$D(%)#2 S %=$P($ZIO,":")_":" ; Call with dsm$xecute()
. S (XWBTDEV,IO,IO(0))=%,X=$E(%_"WKSTA",1,15)
. D SETENV^%ZOSV
. O IO:(SHARE) X ^%ZOSF("TRMOFF")
IF XWBOS="MSM"!(XWBOS="UNIX") D
. S (XWBTDEV,IO,IO(0))=56
IF XWBOS="DSM" S $ETRAP="S %ZTER11S=$STACK D ETRAP^XWBTCPH"
E S X="ETRAP^XWBTCPH",@^%ZOSF("TRAP")
S DIQUIET=1,X="ETRAP^XWBTCPH",@^%ZOSF("TRAP") D DT^DICRW
;S DIQUIET=1 D DT^DICRW
S U="^"
;
MAIN ; -- main message processing loop
F D Q:XWBTBUF="#BYE#"
. ;
. ; -- read client request
. R XWBTBUF#15:600 IF '$T S XWBTBUF="#BYE#" W XWBTBUF,$C(4),! Q
. IF $L(XWBTBUF)=0 S XWBTBUF="#BYE#" W XWBTBUF,$C(4),! Q
. S TYPE=$S($E(XWBTBUF,1,5)="{XWB}":1,1:0)
. S XWBTLEN=$E(XWBTBUF,6,10)
. S XWBPLEN=$E(XWBTBUF,11,15)
. R XWBTBUF#XWBPLEN:XWBTIME
. I $P(XWBTBUF,U)="TCPconnect" D Q
. . W "accept",$C(4),! ;Ack
. IF TYPE D
. . K XWBR
. . IF XWBTBUF="#BYE#" W "#BYE#",$C(4),! Q ; -- clean disconnect
. . S XWBTLEN=XWBTLEN-15
. . ;IF XWBTLEN>240 S XWBR=$$RCN()
. . D CALLP^XWBBRK(.XWBR,XWBTBUF)
. . S XWBPTYPE=$S('$D(XWBPTYPE):1,XWBPTYPE<1:1,XWBPTYPE>6:1,1:XWBPTYPE)
. IF XWBTBUF="#BYE#" Q
. IF XWBOS="DSM"!(XWBOS="UNIX") D SNDDSM
. IF XWBOS="MSM" D SND
. W $C(4),! ;send eot and flush buffer
IF 'TYPE D
. W "#UNKNOWN MESSAGE TYPE#",$C(4),! Q ;end session
;
C XWBTDEV Q
;
SND ; -- Send data (all except DSM)
N I,T
; -- 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 512 chars)
N I,T
; -- 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)))>512 ! 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)))>512 ! 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))>512 ! 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)))>512 ! 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)
U XWBTDEV
IF XWBOS="DSM" D
. I $D(XWBTLEN),XWBTLEN,$ZE'["SYSTEM-F" W XWBERR D @^%ZOSF("ERRTN")
IF XWBOS="MSM" D
. W XWBERR D @^%ZOSF("ERRTN")
C XWBTDEV HALT
;
RCN() ;read entire buffer in chunks of 240 - save in global
N I,T
T S T=$R(10000)+1
L +^TMP("XWB",$J,T):3 IF '$T G T
F I=1:1:(XWBTLEN\240) D
. S ^TMP("XWB",$J,T,I)=$$BREAD(240)
S ^TMP("XWB",$J,T,I+1)=$$BREAD(XWBTLEN#240)
Q "^TMP(""XWB"","_$J_","_T_")"
;
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
;
XWBTCPH ;ISC-SF/EG - TCP/IP PROCESS HANDLER ; 4/28/95
+1 ;;1.0T11;RPC BROKER;;Oct 31, 1995
+2 ;;V1.0T10;KERNEL RPC BROKER;
+3 ;Based on:
+4 ;XQORTCPH ;SLC/KCM - Service TCP Messages [ 12/04/94 9:06 PM ]
+5 ;XWBTCPH ;XXX/KCMO converted to use UCX service; 4/28/95
+6 ;
+7 ;Modified by ISC-SF/EG
+8 ; 0. No longer supports old style OERR messages
+9 ; 1. Makes call to RPC broker
+10 ; 2. Handles MSM Server under Windows NT
+11 ; 3. Handles MSM under Unix - same as DSM
+12 ; 4. Result of an rpc call can be a closed form of global
+13 ; 5. Can receive a large local array, within limits of job
+14 ; partition size.
+15 ; 6. Sets default device to NULL device prior to call, restores
+16 ; at termination. Prevents garbage from 'talking' calls.
+17 ; 7. All reads have a timeout.
+18 ; 8. Intro message is sent when first connected.
+19 ;
EN ; -- Main entry point for the UCX service call
+1 NEW TYPE,XWBTBUF,XWBTBUF1,XWBTDEV,XWBTLEN,XWBTOS,XWBTRTN,XWBWRAP
+2 NEW X,XWBL,XWB1,XWB2,Y,XWBTIME,XWBPTYPE,XWBPLEN,XWBNULL,XWBODEV
+3 SET XWBTIME=1
+4 SET XWBOS=$SELECT(^%ZOSF("OS")["DSM":"DSM",^("OS")["UNIX":"UNIX",1:"MSM")
+5 SET XWBNULL=$SELECT(XWBOS="DSM":"NLA0:",1:"")
+6 IF XWBOS="DSM"
Begin DoDot:1
+7 ; Call with dsm$xecute()
IF '$DATA(%)#2
SET %=$PIECE($ZIO,":")_":"
+8 SET (XWBTDEV,IO,IO(0))=%
SET X=$EXTRACT(%_"WKSTA",1,15)
+9 DO SETENV^%ZOSV
+10 OPEN IO:(SHARE)
XECUTE ^%ZOSF("TRMOFF")
End DoDot:1
+11 IF XWBOS="MSM"!(XWBOS="UNIX")
Begin DoDot:1
+12 SET (XWBTDEV,IO,IO(0))=56
End DoDot:1
+13 IF XWBOS="DSM"
SET $ETRAP="S %ZTER11S=$STACK D ETRAP^XWBTCPH"
+14 IF '$TEST
SET X="ETRAP^XWBTCPH"
SET @^%ZOSF("TRAP")
+15 SET DIQUIET=1
SET X="ETRAP^XWBTCPH"
SET @^%ZOSF("TRAP")
DO DT^DICRW
+16 ;S DIQUIET=1 D DT^DICRW
+17 SET U="^"
+18 ;
MAIN ; -- main message processing loop
+1 FOR
Begin DoDot:1
+2 ;
+3 ; -- read client request
+4 READ XWBTBUF#15:600
IF '$TEST
SET XWBTBUF="#BYE#"
WRITE XWBTBUF,$CHAR(4),!
QUIT
+5 IF $LENGTH(XWBTBUF)=0
SET XWBTBUF="#BYE#"
WRITE XWBTBUF,$CHAR(4),!
QUIT
+6 SET TYPE=$SELECT($EXTRACT(XWBTBUF,1,5)="{XWB}":1,1:0)
+7 SET XWBTLEN=$EXTRACT(XWBTBUF,6,10)
+8 SET XWBPLEN=$EXTRACT(XWBTBUF,11,15)
+9 READ XWBTBUF#XWBPLEN:XWBTIME
+10 IF $PIECE(XWBTBUF,U)="TCPconnect"
Begin DoDot:2
+11 ;Ack
WRITE "accept",$CHAR(4),!
End DoDot:2
QUIT
+12 IF TYPE
Begin DoDot:2
+13 KILL XWBR
+14 ; -- clean disconnect
IF XWBTBUF="#BYE#"
WRITE "#BYE#",$CHAR(4),!
QUIT
+15 SET XWBTLEN=XWBTLEN-15
+16 ;IF XWBTLEN>240 S XWBR=$$RCN()
+17 DO CALLP^XWBBRK(.XWBR,XWBTBUF)
+18 SET XWBPTYPE=$SELECT('$DATA(XWBPTYPE):1,XWBPTYPE<1:1,XWBPTYPE>6:1,1:XWBPTYPE)
End DoDot:2
+19 IF XWBTBUF="#BYE#"
QUIT
+20 IF XWBOS="DSM"!(XWBOS="UNIX")
DO SNDDSM
+21 IF XWBOS="MSM"
DO SND
+22 ;send eot and flush buffer
WRITE $CHAR(4),!
End DoDot:1
IF XWBTBUF="#BYE#"
QUIT
+23 IF 'TYPE
Begin DoDot:1
+24 ;end session
WRITE "#UNKNOWN MESSAGE TYPE#",$CHAR(4),!
QUIT
End DoDot:1
+25 ;
+26 CLOSE XWBTDEV
QUIT
+27 ;
SND ; -- Send data (all except DSM)
+1 NEW I,T
+2 ; -- single value
+3 IF XWBPTYPE=1
SET XWBR=$GET(XWBR)
WRITE XWBR
QUIT
+4 ; -- table delimited by CR+LF
+5 IF XWBPTYPE=2
Begin DoDot:1
+6 SET I=""
FOR
SET I=$ORDER(XWBR(I))
IF I=""
QUIT
WRITE XWBR(I),$CHAR(13,10)
End DoDot:1
QUIT
+7 ; -- word processing
+8 IF XWBPTYPE=3
Begin DoDot:1
+9 SET I=""
FOR
SET I=$ORDER(XWBR(I))
IF I=""
QUIT
WRITE XWBR(I)
IF XWBWRAP
WRITE $CHAR(13,10)
End DoDot:1
QUIT
+10 ; -- global array
+11 IF XWBPTYPE=4
Begin DoDot:1
+12 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
+13 ; -- global instance
+14 IF XWBPTYPE=5
SET XWBR=$GET(@XWBR)
WRITE XWBR
QUIT
+15 ; -- variable length records
+16 IF XWBPTYPE=6
SET I=""
FOR
SET I=$ORDER(XWBR(I))
IF I=""
QUIT
WRITE $CHAR($LENGTH(XWBR(I))),XWBR(I)
+17 QUIT
SNDDSM ; -- send data for DSM (requires buffer flush (!) every 512 chars)
+1 NEW I,T
+2 ; -- single value
+3 IF XWBPTYPE=1
SET XWBR=$GET(XWBR)
WRITE XWBR
QUIT
+4 ; -- table delimited by CR+LF
+5 IF XWBPTYPE=2
Begin DoDot:1
+6 SET I=""
FOR
SET I=$ORDER(XWBR(I))
IF I=""
QUIT
IF ($X+$LENGTH(XWBR(I)))>512
WRITE !
WRITE XWBR(I),$CHAR(13,10)
End DoDot:1
QUIT
+7 ; -- word processing
+8 IF XWBPTYPE=3
Begin DoDot:1
+9 SET I=""
FOR
SET I=$ORDER(XWBR(I))
IF I=""
QUIT
IF ($X+$LENGTH(XWBR(I)))>512
WRITE !
WRITE XWBR(I)
IF XWBWRAP
WRITE $CHAR(13,10)
End DoDot:1
QUIT
+10 ; -- global array
+11 IF XWBPTYPE=4
Begin DoDot:1
+12 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))>512
WRITE !
WRITE @I
IF XWBWRAP&(@I'=$CHAR(13,10))
WRITE $CHAR(13,10)
End DoDot:1
QUIT
+13 ; -- global instance
+14 IF XWBPTYPE=5
SET XWBR=$GET(@XWBR)
WRITE XWBR
QUIT
+15 ; -- variable length records
+16 IF XWBPTYPE=6
SET I=""
FOR
SET I=$ORDER(XWBR(I))
IF I=""
QUIT
IF ($X+$LENGTH(XWBR(I)))>512
WRITE !
WRITE $CHAR($LENGTH(XWBR(I))),XWBR(I)
+17 QUIT
+18 ;
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 USE XWBTDEV
+4 IF XWBOS="DSM"
Begin DoDot:1
+5 IF $DATA(XWBTLEN)
IF XWBTLEN
IF $ZE'["SYSTEM-F"
WRITE XWBERR
DO @^%ZOSF("ERRTN")
End DoDot:1
+6 IF XWBOS="MSM"
Begin DoDot:1
+7 WRITE XWBERR
DO @^%ZOSF("ERRTN")
End DoDot:1
+8 CLOSE XWBTDEV
HALT
+9 ;
RCN() ;read entire buffer in chunks of 240 - save in global
+1 NEW I,T
T SET T=$RANDOM(10000)+1
+1 LOCK +^TMP("XWB",$JOB,T):3
IF '$TEST
GOTO T
+2 FOR I=1:1:(XWBTLEN\240)
Begin DoDot:1
+3 SET ^TMP("XWB",$JOB,T,I)=$$BREAD(240)
End DoDot:1
+4 SET ^TMP("XWB",$JOB,T,I+1)=$$BREAD(XWBTLEN#240)
+5 QUIT "^TMP(""XWB"","_$JOB_","_T_")"
+6 ;
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 ;
