| 1 | XOBVTCPL ;; mjk/alb - VistALink TCP/IP Listener (Cache NT) ; 07/27/2002 13:00
|
|---|
| 2 | ;;1.5;VistALink;;Sep 09, 2005
|
|---|
| 3 | ;;Foundations Toolbox Release v1.5 [Build: 1.5.0.026]
|
|---|
| 4 | ;
|
|---|
| 5 | QUIT
|
|---|
| 6 | ;
|
|---|
| 7 | ; -- Important: Should always be JOBed using START^XOBVTCP
|
|---|
| 8 | LISTENER(XOBPORT,XOBCFG) ; -- Start Listener
|
|---|
| 9 | ;
|
|---|
| 10 | ; -- quit if not Cache for NT
|
|---|
| 11 | IF $$GETOS^XOBVTCP()'="OpenM-NT" QUIT
|
|---|
| 12 | ;
|
|---|
| 13 | NEW $ETRAP,$ESTACK SET $ETRAP="D ^%ZTER HALT"
|
|---|
| 14 | ;
|
|---|
| 15 | NEW X,POP,XOBDA,U,DTIME,DT,XOBIO
|
|---|
| 16 | SET U="^",DTIME=900,DT=$$DT^XLFDT()
|
|---|
| 17 | IF $GET(DUZ)="" NEW DUZ SET DUZ=.5,DUZ(0)="@"
|
|---|
| 18 | ;
|
|---|
| 19 | ; -- only start if not already started
|
|---|
| 20 | IF $$LOCK^XOBVTCP(XOBPORT) DO
|
|---|
| 21 | . IF $$OPENM(.XOBIO,XOBPORT) DO
|
|---|
| 22 | . . ; -- listener started and now stopping
|
|---|
| 23 | . . SET IO=XOBIO
|
|---|
| 24 | . . DO CLOSE^%ZISTCP
|
|---|
| 25 | . . ; -- update status to 'stopped'
|
|---|
| 26 | . . DO UPDATE^XOBVTCP(XOBPORT,4,$GET(XOBCFG))
|
|---|
| 27 | . ELSE DO
|
|---|
| 28 | . . ; -- listener failed to start
|
|---|
| 29 | . . ; -- update status to 'failed'
|
|---|
| 30 | . . DO UPDATE^XOBVTCP(XOBPORT,5,$GET(XOBCFG))
|
|---|
| 31 | . ;
|
|---|
| 32 | . DO UNLOCK^XOBVTCP(XOBPORT)
|
|---|
| 33 | QUIT
|
|---|
| 34 | ;
|
|---|
| 35 | ; -- open/start listener port
|
|---|
| 36 | OPENM(XOBIO,XOBPORT) ;
|
|---|
| 37 | NEW XOBBOX,%ZA
|
|---|
| 38 | SET XOBBOX=+$$GETBOX^XOBVTCP()
|
|---|
| 39 | SET XOBIO="|TCP|"_XOBPORT
|
|---|
| 40 | OPEN XOBIO:(:XOBPORT:"AT"):30
|
|---|
| 41 | ;
|
|---|
| 42 | ; -- if listener port could not be openned then gracefully quit
|
|---|
| 43 | ; (other namespace using port maybe?)
|
|---|
| 44 | IF '$TEST QUIT 0
|
|---|
| 45 | ;
|
|---|
| 46 | ; -- indicate listener is 'running'
|
|---|
| 47 | DO UPDATE^XOBVTCP(XOBPORT,2,$GET(XOBCFG))
|
|---|
| 48 | ; -- read & spawn loop
|
|---|
| 49 | FOR DO QUIT:$$EXIT(XOBBOX,XOBPORT)
|
|---|
| 50 | . USE XOBIO
|
|---|
| 51 | . READ *X:60 IF '$TEST QUIT
|
|---|
| 52 | . JOB CHILDNT^XOBVTCPL():(:4:XOBIO:XOBIO):10 SET %ZA=$ZA
|
|---|
| 53 | . IF %ZA\8196#2=1 WRITE *-2 ;Job failed to clear bit
|
|---|
| 54 | QUIT 1
|
|---|
| 55 | ;
|
|---|
| 56 | CHILDNT() ;Child process for OpenM
|
|---|
| 57 | NEW XOBEC
|
|---|
| 58 | SET $ETRAP="D ^%ZTER L HALT"
|
|---|
| 59 | SET IO=$PRINCIPAL ;Reset IO to be $P
|
|---|
| 60 | USE IO:(::"-M") ;Packet mode like DSM
|
|---|
| 61 | ; -- do quit to save a stack level
|
|---|
| 62 | SET XOBEC=$$NEWOK()
|
|---|
| 63 | IF XOBEC DO LOGINERR(XOBEC,IO)
|
|---|
| 64 | IF 'XOBEC DO VAR,SPAWN^XOBVLL
|
|---|
| 65 | QUIT
|
|---|
| 66 | ;
|
|---|
| 67 | VAR ;Setup IO variables
|
|---|
| 68 | SET IO(0)=IO,IO(1,IO)="",POP=0
|
|---|
| 69 | SET IOT="TCP",IOF="#",IOST="P-TCP",IOST(0)=0
|
|---|
| 70 | QUIT
|
|---|
| 71 | ;
|
|---|
| 72 | NEWOK() ;Is it OK to start a new process
|
|---|
| 73 | NEW XQVOL,XUVOL,X,XOBCODE,Y
|
|---|
| 74 | SET U="^"
|
|---|
| 75 | DO GETENV^%ZOSV SET XQVOL=$PIECE(Y,U,2)
|
|---|
| 76 | SET X=$$FIND1^DIC(8989.304,",1,","BX",XQVOL,"","",""),XUVOL=$SELECT(X>0:^XTV(8989.3,1,4,X,0),1:XQVOL_"^y^1")
|
|---|
| 77 | SET XOBCODE=$$INHIBIT^XUSRB()
|
|---|
| 78 | IF XOBCODE=1 QUIT 181004
|
|---|
| 79 | IF XOBCODE=2 QUIT 181003
|
|---|
| 80 | QUIT 0
|
|---|
| 81 | ;
|
|---|
| 82 | ; -- process error
|
|---|
| 83 | LOGINERR(XOBEC,XOBPORT) ;
|
|---|
| 84 | DO ERROR^XOBVLL(XOBEC,$$EZBLD^DIALOG(XOBEC),XOBPORT)
|
|---|
| 85 | ;
|
|---|
| 86 | ; -- give client time to process stream
|
|---|
| 87 | HANG 2
|
|---|
| 88 | QUIT
|
|---|
| 89 | ;
|
|---|
| 90 | EXIT(XOBBOX,XOBPORT) ;
|
|---|
| 91 | ; -- is status 'stopping'
|
|---|
| 92 | QUIT ($PIECE($GET(^XOB(18.04,+$$GETLOGID(XOBBOX,XOBPORT),0)),U,3)=3)
|
|---|
| 93 | ;
|
|---|
| 94 | GETLOGID(XOBBOX,XOBPORT) ;
|
|---|
| 95 | QUIT +$ORDER(^XOB(18.04,"C",XOBBOX,XOBPORT,""))
|
|---|
| 96 | ;
|
|---|
