source: FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZISTCPS.m@ 1755

Last change on this file since 1755 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.1 KB
Line 
1%ZISTCPS ;ISF/RWF - DEVICE HANDLER TCP/IP SERVER CALLS ;06/20/2005 09:11
2 ;;8.0;KERNEL;**78,118,127,225,275,388**;Jul 10, 1995
3 Q
4 ;
5CLOSE ;Close and reset
6 G CLOSE^%ZISTCP
7 Q
8 ;
9 ;In ZRULE, set ZISQUIT=1 to quit
10LISTEN(SOCK,RTN,ZRULE) ;Listen on socket, start routine
11 N %A,ZISOS,X,NIO,EXIT
12 N $ES,$ET S $ETRAP="D OPNERR^%ZISTCPS"
13 S ZISOS=^%ZOSF("OS"),ZRULE=$G(ZRULE)
14 S POP=1
15 D GETENV^%ZOSV S U="^",XUENV=Y,XQVOL=$P(Y,U,2)
16 S POP=1 D LONT:ZISOS["OpenM",LGTM:ZISOS["GT.M"
17 I 'POP C NIO ;Close port
18 Q
19 ;
20 ;
21LONT ;Open port in Accept mode with standard terminators.
22 N %ZA,NEWCHAR
23 S NIO="|TCP|"_SOCK,EXIT=0
24 ;(adr:sock:term:ibuf:obuf:queue)
25 O NIO:(:SOCK:"AT"::512:512:10):30 Q:'$T S POP=0 U NIO
26 ;Wait on read for a connect
27LONT2 F U NIO R *NEWCHAR:30 S EXIT=$$EXIT Q:$T!EXIT
28 I EXIT C NIO Q
29 ;JOB params (:Concurrent Server bit:principal input:principal output)
30 J CHILDONT^%ZISTCPS(NIO,RTN):(:16::):10 S %ZA=$ZA
31 I %ZA\8196#2=1 W *-2 ;Job failed to clear bit
32 G LONT2
33 ;
34CHILDONT(IO,RTN) ;Child process for OpenM
35 S $ETRAP="D ^%ZTER L HALT",IO=$ZU(53)
36 U IO:(::"-M") ;Work like DSM
37 S NEWJOB=$$NEWOK
38 I 'NEWJOB W "421 Service temporarily down.",$C(13,10),!
39 I NEWJOB K NEWJOB D VAR,@RTN
40 HALT
41 ;
42VAR ;Setup IO variables
43 S IO(0)=IO,IO(1,IO)="",POP=0
44 S IOT="TCP",IOST="P-TCP",IOST(0)=0
45 S IOF=$$FLUSHCHR^%ZISTCP
46 S ^XUTL("XQ",$J,0)=$$DT^XLFDT
47 Q
48NEWOK() ;Is it OK to start a new process
49 I $G(^%ZIS(14.5,"LOGON",^%ZOSF("VOL"))) Q 0
50 I $$AVJ^%ZOSV()<3 Q 0
51 Q 1
52OPNERR ;
53 S POP=1,EXIT=1,IO("ERROR")=$ECODE,$ECODE=""
54 Q
55EXIT() ;See if time to exit
56 I $$S^%ZTLOAD Q 1
57 N ZISQUIT S ZISQUIT=0
58 I $L(ZRULE) X ZRULE I $G(ZISQUIT) Q 1
59 Q 0
60 ;
61LGTM ;GT.M multi thread server
62 N %A K ^TMP("ZISTCP",$J)
63 S $ZINTERRUPT="I $$JOBEXAM^ZU($ZPOSITION)"
64 S NIO="SCK$"_$S($J>86400:$J,1:84600+$J) ;Construct a dummy, but "unique" devicename for job
65 D LOG("Open for Listen "_NIO)
66 ;Open the device
67 O NIO:(ZLISTEN=SOCK_":TCP":ATTACH="listener"):30:"SOCKET"
68 I '$T D LOG("Can't Open Socket: "_SOCK) Q
69 U NIO S NIO("ZISTCP",0)=$KEY D LOG("Have port.")
70 ;Start Listening
71 W /LISTEN(1) S NIO("ZISTCP",1)=$KEY D LOG("Start Listening. "_NIO("ZISTCP",1))
72 ;Wait for connection
73LG2 S %A=0,EXIT=0 F D Q:%A!EXIT
74 . W /WAIT(30) ;Wait for connect
75 . I $P($KEY,"|",1)="CONNECT" S NIO("ZISTCP",2)=$KEY,%A=1
76 . S EXIT=$$EXIT
77 . Q
78 I EXIT C NIO Q
79 ;
80 S NIO("SOCK")=$P($G(NIO("ZISTCP",2)),"|",2)
81 D LOG("Got connection on "_NIO("SOCK"))
82 I '$$NEWOK D G LG2
83 . U NIO:(SOCKET=NIO("SOCK")) W "421 Service temporarily down.",$C(13,10),#
84 . C NIO:(SOCKET=NIO("SOCK")) K NIO("ZISTCP",2)
85 . Q
86 ;Close the main socket
87 C NIO:(SOCKET="listener")
88 ;Start a new listener
89 J LISTEN^%ZISTCPS(SOCK,RTN,ZRULE)
90 ;Use the new socket
91 ;U NIO:(SOCKET=NIO("SOCK"):WIDTH=512:NOWRAP:IOERROR="TRAP")
92 U NIO:(SOCKET=NIO("SOCK"):WIDTH=512:NOWRAP)
93 ;Run the job
94 D GTMLNCH(NIO,RTN)
95 S POP=0
96 Q
97 ;
98GTMLNCH(IO,RTN) ;Run gt.m job for this conncetion.
99 N NIO,SOCK,ZISOS,EXIT,XQVOL,$ETRAP
100 S U="^",$ETRAP="D ^%ZTER L HALT"
101 S IO(0)=IO,IO(1,IO)=""
102 D VAR,@RTN
103 Q $D(IO("C")) ;Use IO("C") to quit server
104 ;
105LOG(MSG) ;LOG STATUS
106 N CNT
107 S CNT=$G(^TMP("ZISTCP",$J))+1,^TMP("ZISTCP",$J)=CNT,^($J,CNT)=MSG
108 Q
109 ;
Note: See TracBrowser for help on using the repository browser.