Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XWBTCP

XWBTCP.m

Go to the documentation of this file.
  1. XWBTCP ;ISF/EG,ISD/HGW - Control TCP listener ;10/22/14 11:32
  1. ;;1.1;RPC BROKER;**1,9,35,64**;Mar 28, 1997;Build 12
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. EN ; -- entry point for interactive use
  1. N X1,X2,XWBTDBG,XWBIP
  1. S XWBIP=""
  1. S:$G(IO("IP"))]"" XWBIP=IO("IP")
  1. W !,"Enter client address: "_XWBIP_"//" R X1:300 Q:'$T Q:X1="^"
  1. W !," Enter client port: " R X2:300 Q:'$T Q:X2="^"
  1. W ! S XWBTDBG=""
  1. IF X1="" S X1=XWBIP
  1. IF $L(X1),$L(X2) D EN^XWBTCPC(X1,X2,"","1.08")
  1. Q
  1. ;
  1. STATSCRN(XWBNEW) ;Port STATUS field screen
  1. ;DA: FileMan DA array. See STATCHG tag bellow for detailed descr.
  1. ;XWBCUR: Current value of STATUS field
  1. ;XWBNEW: New/requested value of STATUS field
  1. ; The domain for XWBCUR and XWBNEW is the same as for the
  1. ; ACTION variable, described at STATCHG tag bellow.
  1. N C,XWBCUR,RESULT
  1. S C=","
  1. S XWBCUR=$$GET1^DIQ(8994.171,DA_C_DA(1)_C_DA(2)_C,"STATUS","I")
  1. S RESULT=0
  1. I XWBCUR=3,XWBNEW=4 S RESULT=1 ;if stopping a running listener
  1. I XWBCUR=6,XWBNEW=1 S RESULT=1 ;if starting a stopped listener
  1. ; the next two cases are most usefull whenever some error occurs
  1. ; and the STATUS field is stuck in STARTING or RUNNING state
  1. I XWBCUR=2,XWBNEW=3 S RESULT=1 ;change to RUNNING if it's starting
  1. I XWBCUR=5,XWBNEW=6 S RESULT=1 ;change to STOPPED if it's stopping
  1. Q RESULT
  1. ;
  1. ;
  1. STATCHG(DA,ACTION) ;STATUS field X-ref SET logic
  1. ;DA: FileMan DA array
  1. ; DA =IEN of the port
  1. ; DA(1) =IEN of the BOX-VOLUME
  1. ; DA(2) =IEN of site/domain
  1. ;ACTION: Requested value for the STATUS field. Possible values are:
  1. ; 1 = START, 2 = STARTING, 3 = RUNNING,
  1. ; 4 = STOP, 5 = STOPPING, 6 = STOPPED
  1. N C,ZTCPU,TYPE,XWBPORT,XWBFDA
  1. S C=","
  1. ;
  1. I ACTION=1!(ACTION=4) D
  1. . S ZTCPU=$$GET1^DIQ(8994.17,DA(1)_C_DA(2)_C,"BOX-VOLUME PAIR")
  1. . S XWBPORT=$$GET1^DIQ(8994.171,DA_C_DA(1)_C_DA(2)_C,"PORT")
  1. . ;S TYPE=$$GET1^DIQ(8994.171,DA_C_DA(1)_C_DA(2)_C,"TYPE OF LISTENER","I")
  1. . S TYPE=1 ; only start new-style listener, old-style listener is deprecated
  1. . ;UCI is no longer derived from the file, but comes from current
  1. . ;environment. The reason for that is it makes no sense to start
  1. . ;a listener in a UCI where ^XWB can't be reached to change status.
  1. . D GETENV^%ZOSV
  1. . S ZTUCI=$P(Y,U),ZTIO="",ZTREQ="@",ZTDTH=$H ;run it ASAP
  1. . I ACTION=1 D ; -- START listener
  1. . . S ZTDESC="RPC Broker Listener START on "_ZTUCI_"-"_ZTCPU_", port "_XWBPORT
  1. . . S ZTRTN=$S(TYPE=1:"ZISTCP^XWBTCPM1("_XWBPORT_")",1:"EN^XWBTCPL("_XWBPORT_")")
  1. . E D ; -- STOP listener
  1. . . S ZTDESC="RPC Broker Listener STOP on "_ZTUCI_"-"_ZTCPU_", port "_XWBPORT
  1. . . S ZTRTN="STOP^XWBTCP("_XWBPORT_")"
  1. . D EN^DDIOL("Task: "_ZTDESC,"","!?10") ;inform user
  1. . D ^%ZTLOAD ; queue it
  1. . D EN^DDIOL("has been queued as task "_ZTSK,"","!?10") ;inform user
  1. . ; -- change STATUS from START to STARTING or from STOP to STOPPING
  1. . D FDA^DILF(8994.171,DA_C_DA(1)_C_DA(2)_C,1,"R",ACTION+1,"XWBFDA")
  1. . D FILE^DIE("K","XWBFDA")
  1. Q
  1. ;
  1. ;
  1. STRT(XWBTSKT) ;start TCP Listener. Interactive entry point
  1. N IP,REF,Y,%
  1. S U="^" D HOME^%ZIS
  1. W "Start TCP Listener...",!
  1. X ^%ZOSF("UCI") S REF=Y
  1. S IP=$$CONVERT^XLFIPV("::0") ;get server IP at some point, start with null address
  1. IF $G(XWBTSKT)="" S XWBTSKT=9000 ;default service port is 9000
  1. ;
  1. ; -- see if 'running flag' for listener is set
  1. I '$$SEMAPHOR^XWBTCPL(XWBTSKT,"LOCK") W "TCP Listener on port "_XWBTSKT_" appears to be running already.",! Q
  1. S %=$$SEMAPHOR^XWBTCPL(XWBTSKT,"UNLOCK")
  1. ;
  1. D MARKER(XWBTSKT,1) ;record problem marker
  1. ; -- start the listener
  1. J EN^XWBTCPL(XWBTSKT)::5 ;Used in place of TaskMan, Need to start on any node.
  1. I '$T W "Unable to run TCP Listener in background.",! Q
  1. F %=1:1:5 D Q:%=0
  1. . W "Checking if TCP Listener has started...",!
  1. . H 3
  1. . S:'$$MARKER(XWBTSKT,0) %=0
  1. I $$MARKER(XWBTSKT,0) D
  1. . W !,"TCP Listener could not be started!",!
  1. . W "Check if port "_XWBTSKT_" is busy on this CPU.",!
  1. . D MARKER(XWBTSKT,-1) ;clear marker
  1. E W "TCP Listener started successfully."
  1. Q
  1. ;
  1. MARKER(PORT,MODE) ;Set/Test/Clear Problem Marker, Mode=0 is a function
  1. N IP,Y,%,REF X ^%ZOSF("UCI") S REF=Y,IP=$$CONVERT^XLFIPV("::0"),%=0
  1. L +^XWB(IP,REF,XWBTSKT,"PROBLEM MARKER")
  1. I MODE=1 S ^XWB(IP,REF,XWBTSKT,"PROBLEM MARKER")=1
  1. I MODE=0 S:$D(^XWB(IP,REF,XWBTSKT,"PROBLEM MARKER")) %=1
  1. I MODE=-1 K ^XWB(IP,REF,XWBTSKT,"PROBLEM MARKER")
  1. L -^XWB(IP,REF,XWBTSKT,"PROBLEM MARKER")
  1. Q:MODE=0 % Q
  1. ;
  1. STRTALL ;XWB LISTENER STARTER option entry point
  1. ;here all listener entries in RPC Broker Site Parameters file that
  1. ;have CONTROLLED BY LISTENER STARTER set to 1/Yes will be started.
  1. N E,LSTN,LSTNID,LSTNIENS,PORTID,XWBSCR,XWBDA
  1. ;XWBDA: Namespaced FileMan DA array
  1. ; XWBDA =IEN of the port
  1. ; XWBDA(1) =IEN of the BOX-VOLUME
  1. ; XWBDA(2) =IEN of site/domain
  1. S E=""
  1. S XWBDA(2)=1 ;hard set IEN of site/domain
  1. ; -- screen out RUNNING (STATUS=3) listeners and those that aren't controlled by XWB LISTENER STARTER option.
  1. S XWBSCR="I $P(^(0),U,2)'=3,$P(^(0),U,4)"
  1. ; -- get top level listners box-volume
  1. D LIST^DIC(8994.17,",1,",E,E,E,E,E,E,E,E,$NA(LSTN("LSTNR")))
  1. S LSTNID=""
  1. F S LSTNID=$O(LSTN("LSTNR","DILIST",1,LSTNID)) Q:LSTNID="" D
  1. . S XWBDA(1)=LSTN("LSTNR","DILIST",2,LSTNID) ;IEN of each listener
  1. . S LSTNIENS=","_XWBDA(1)_","_XWBDA(2)_","
  1. . D LIST^DIC(8994.171,LSTNIENS,E,"P",E,E,E,E,XWBSCR,E,$NA(LSTN("PORT")))
  1. . S PORTID=0
  1. . F S PORTID=$O(LSTN("PORT","DILIST",PORTID)) Q:PORTID="" D
  1. . . S XWBDA=$P(LSTN("PORT","DILIST",PORTID,0),U,1)
  1. . . D STATCHG(.XWBDA,1) ;use STATUS field X-ref SET logic to queue up start of a listener
  1. Q
  1. ;
  1. STOPALL ;XWB LISTENER STOP ALL entry point
  1. ;here all listener entries in RPC Broker Site Parameters file that
  1. ;have CONTROLLED BY LISTENER STARTER set to 1/Yes will be stopped.
  1. N E,LSTN,LSTNID,LSTNIENS,PORTID,XWBSCR,XWBDA
  1. ;XWBDA: Namespaced FileMan DA array
  1. ; XWBDA =IEN of the port
  1. ; XWBDA(1) =IEN of the BOX-VOLUME
  1. ; XWBDA(2) =IEN of site/domain
  1. S E=""
  1. S XWBDA(2)=1 ;hard set IEN of site/domain
  1. ; -- screen out STOPPED (STATUS=3) listeners and those that aren't controlled by XWB LISTENER STARTER option.
  1. S XWBSCR="I $P(^(0),U,2)'=6,$P(^(0),U,4)"
  1. ; -- get top level listners box-volume
  1. D LIST^DIC(8994.17,",1,",E,E,E,E,E,E,E,E,$NA(LSTN("LSTNR")))
  1. S LSTNID=""
  1. F S LSTNID=$O(LSTN("LSTNR","DILIST",1,LSTNID)) Q:LSTNID="" D
  1. . S XWBDA(1)=LSTN("LSTNR","DILIST",2,LSTNID) ;IEN of each listener
  1. . S LSTNIENS=","_XWBDA(1)_","_XWBDA(2)_","
  1. . D LIST^DIC(8994.171,LSTNIENS,E,"P",E,E,E,E,XWBSCR,E,$NA(LSTN("PORT")))
  1. . S PORTID=0
  1. . F S PORTID=$O(LSTN("PORT","DILIST",PORTID)) Q:PORTID="" D
  1. . . S XWBDA=$P(LSTN("PORT","DILIST",PORTID,0),U,1)
  1. . . D STATCHG(.XWBDA,4) ;use STATUS field X-ref SET logic to queue up stop of a listener
  1. Q
  1. ;
  1. RESTART ;Stop and then Start all listeners.
  1. D STOPALL H 15 D STRTALL
  1. Q
  1. ;
  1. STOP(XWBTSKT) ;stop TCP Listener. Interactive and TaskMan entry point
  1. N IP,REF,X,DEV,XWBOS,XWBIP,XWBENV
  1. S U="^" D HOME^%ZIS,GETENV^%ZOSV S XWBENV=Y
  1. D EN^DDIOL("Stop TCP Listener...")
  1. X ^%ZOSF("UCI") S REF=Y
  1. S IP=$$CONVERT^XLFIPV("::0") ;get server IP, start with null address
  1. IF $G(XWBTSKT)="" S XWBTSKT=9000 ;default service port is 9000
  1. ;
  1. S XWBOS=$S(^%ZOSF("OS")["DSM":"DSM",^("OS")["MSM":"MSM",^("OS")["OpenM":"OpenM",1:"") ;RWF
  1. ;
  1. ; -- make sure the listener is running
  1. I $$SEMAPHOR^XWBTCPL(XWBTSKT,"LOCK") D Q
  1. . S %=$$SEMAPHOR^XWBTCPL(XWBTSKT,"UNLOCK")
  1. . D EN^DDIOL("TCP Listener does not appear to be running.")
  1. ;
  1. S X=$$NODE^XWBTCPM1(XWBTSKT) ;Get node
  1. I $P(X,"^",3)=1 D Q
  1. . D EN^DDIOL("New listener should stop on its own")
  1. ;
  1. ; -- send the shutdown message to the TCP Listener process
  1. ; using loopback address
  1. S XWBIP=$$CONVERT^XLFIPV("::1") ; start with loopback address
  1. D CALL^%ZISTCP(XWBIP,XWBTSKT) I POP D Q
  1. . S %=$$SEMAPHOR^XWBTCPL(XWBTSKT,"UNLOCK")
  1. . D EN^DDIOL("TCP Listener does not appear to be running.")
  1. U IO
  1. ;
  1. S X=$T(+2),X=$P(X,";;",2),X=$P(X,";")
  1. IF X="" S X=0
  1. S X=$C($L(X))_X
  1. W "{XWB}00020|"_X_"00011TCPshutdown",!
  1. R X:5
  1. D CLOSE^%ZISTCP
  1. IF X["ack" D EN^DDIOL("TCP Listener has been shutdown.")
  1. ELSE D EN^DDIOL("Shutdown Failed!")
  1. Q
  1. ;
  1. DEBUG ;Edit the debug parameter
  1. W !!
  1. D EDITPAR^XPAREDIT("XWBDEBUG")
  1. W !!
  1. Q