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

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

initial load of WorldVistAEHR

File size: 5.2 KB
Line 
1%ZISTCP ;ISC-SF/RWF - DEVICE HANDLER TCP/IP CALLS ;06/23/2004 09:09
2 ;;8.0;KERNEL;**36,34,59,69,118,225,275**;Jul 10, 1995
3 Q
4 ;
5CALL(IP,SOCK,TO) ;Open a socket to the IP address <procedure>
6 N %A,ZISOS,X,NIO
7 S ZISOS=^%ZOSF("OS"),TO=$G(TO,30)
8 N $ETRAP S $ETRAP="G OPNERR^%ZISTCP"
9 S POP=1
10 I IP'?1.3N1P1.3N1P1.3N1P1.3N S IP=$$ADDRESS^XLFNSLK(IP) ;Lookup the name
11 I IP'?1.3N1P1.3N1P1.3N1P1.3N Q ;Not in the IP format
12 I (SOCK<1)!(SOCK>65535) Q
13 G CVXD:ZISOS["VAX",CONT:ZISOS["OpenM",CGTM:ZISOS["GT.M",CMSM:ZISOS["MSM"
14 S POP=1
15 Q
16CVXD ;Open VAX DSM Socket
17 S NIO=SOCK
18 O NIO:(TCPCHAN,ADDRESS=IP):TO G:'$T NOOPN
19 U NIO:NOECHO D VAR(NIO)
20 Q
21CMSM ;Open MSM Socket
22 S NIO=56 O NIO::TO G:'$T NOOPN
23 U NIO::"TCP" W /SOCKET(IP,SOCK) I $KEY="" C NIO G NOOPN
24 D VAR(NIO)
25 Q
26CONT ;Open OpenM socket
27 I $$VERSION^%ZOSV'<5 S %A=$ZUTIL(68,55,1)
28 S NIO="|TCP|"_SOCK
29 O NIO:(IP:SOCK:"-M"::512:512):TO G:'$T NOOPN ;Make work like DSM
30 U NIO D VAR(NIO)
31 Q
32CGTM ;Open GT.M Socket
33 S NIO="SCK$"_$P($H,",",2) ;Just needs to be unique for job
34 O NIO:(CONNECT=IP_":"_SOCK_":TCP":ATTACH="client"):TO:"SOCKET"
35 I '$T S POP=1 Q
36 U NIO S NIO("KEY")=$KEY
37 S NIO("SOCKET")=$P(NIO("KEY"),"|",2)
38 I $P(NIO("KEY"),"|")'="ESTABLISHED" D LOG("** ="_NIO("KEY")_"= **") W 1/0 ; PROTOCOL ERROR
39 ;U NIO:(SOCKET=NIO("SOCKET"):WIDTH=512:NOWRAP:IOERROR="TRAP":EXCEPT="G GTMERR^%ZISTCP")
40 U NIO:(SOCKET=NIO("SOCKET"):WIDTH=512:NOWRAP:EXCEPT="G GTMERR^%ZISTCP")
41 D VAR(NIO) S IOF="#" ;Set buffer flush
42 Q
43 ;
44VAR(%IO) ;Setup IO variables
45 S:'$D(IO(0)) IO(0)=$I
46 S IO=%IO,IO(1,IO)=$G(IP),POP=0
47 ;Set IOF to the normal buffer flush. W @IOF.
48 S IOT="TCP",IOST="P-TCP",IOST(0)=0
49 S IOF=$$FLUSHCHR
50 Q
51NOOPN ;Didn't make the conection
52 S POP=1
53 Q
54OPNERR ;
55 ;D ^%ZTER
56 S POP=1
57 D ERRCLR
58 Q
59UCXOPEN(NIO) ;This call only applies to SERVER jobs tied to UCX/VMS
60 N $ETRAP,%ZISV,%ZISOS S $ETRAP="G OPNERR^%ZISTCP"
61 S %ZISV=$$VERSION^%ZOSV,%ZISOS=^%ZOSF("OS"),POP=1
62 I %ZISOS["DSM",%ZISV<7 O NIO:(SHARE):5 D:$T VAR(NIO)
63 I %ZISOS["DSM",%ZISV'<7 S NIO="SYS$NET" O NIO:(TCPDEV):5 D:$T VAR(NIO)
64 Q
65 ;
66CLOSE ;Close and reset
67 N NIO,$ETRAP S $ETRAP="G CLOSEX^%ZISTCP"
68 S NIO=IO,IO=$S($G(IO(0))]"":IO(0),1:$P)
69 I NIO]"" C NIO K IO(1,NIO) S IO("CLOSE")=NIO
70CLOSEX D HOME^%ZIS
71 D ERRCLR
72 Q
73ERRCLR ;
74 S:$ECODE]"" IO("LASTERR")=$G(IO("ERROR")),IO("ERROR")=$ECODE,$ECODE=""
75 Q
76 ;
77FLUSHCHR() ;Return the value to write @ of to flush the TCP buffer
78 N OS S OS=$P(^%ZOSF("OS"),"^")
79 Q $S(OS["GT.M":"#",1:"!")
80 ;
81 ;In ZRULE, set ZISQUIT=1 to quit
82LISTEN(SOCK,RTN,ZRULE) ;Listen on socket, run routine, single thread.
83 N %A,ZISOS,X,NIO,EXIT,IOF,IP
84 N $ES,$ET S $ET="D OPNERR^%ZISTCP"
85 S ZISOS=^%ZOSF("OS"),ZRULE=$G(ZRULE)
86 D GETENV^%ZOSV S U="^",XUENV=Y,XQVOL=$P(Y,U,2)
87 S POP=1
88 I $G(^%ZIS(14.5,"LOGON",XQVOL)) Q
89LOOP S POP=1 D LVXD:ZISOS["DSM",LONT:ZISOS["OpenM",LGTM:ZISOS["GT.M",LMSM:ZISOS["MSM"
90 I POP Q ;Quit Server
91 S EXIT=0,EXIT=$$LAUNCH(NIO,RTN)
92 I $G(^%ZIS(14.5,"LOGON",XQVOL)) S EXIT=1
93 I ZISOS["DSM" X "U NIO:DISCONNECT"
94 E C NIO ;
95 Q:EXIT ;Quit server, App set IO("C"), Logon inhibit.
96 G LOOP
97 ;
98LMSM ;MSM
99 ;For multi thread use MSM's MSERVER process.
100 ;This is the listener for TCP connects.
101 S NIO=56 O NIO::30 Q:'$T S POP=0
102 U NIO::"TCP" W /SOCKET("",SOCK)
103 S POP=$$EXIT
104 Q
105 ;
106LONT ;Open port in Accept mode with standard terminators, standard buffers.
107 N %ZA,%ZB
108 S NIO="|TCP|"_SOCK,%A=0
109 ;(adr:sock:term:ibuf:obuf:queue)
110 O NIO:(:SOCK:"AT"::512:512:3):30 Q:'$T S POP=0
111 ;Wait on read for a connect
112 U NIO F D Q:%A!POP
113 . R *NEWCHAR:60 S %ZA=$ZA,%ZB=$ZB S:$T %A=1 Q:%A
114 . S POP=$$EXIT
115 I POP C NIO Q
116 U NIO:(::"-M") ;Work like DSM
117 Q
118 ;
119LVXD ;Open port and listen
120 ;Use UCX for multiple listeners
121 S NIO=SOCK O NIO:(TCPCHAN):30 Q:'$T S POP=0
122 U NIO ;Let application wait at the read for a connect.
123 Q
124 ;
125LGTM ;GT.M single thread server
126 N %A K ^TMP("ZISTCP",$J)
127 S $ZINTERRUPT="I $$JOBEXAM^ZU($ZPOSITION)"
128 S NIO="SCK$"_$S($J>86400:$J,1:84600+$J) ;Construct a dummy, but "unique" devicename for job
129 D LOG("Open for Listen "_NIO)
130 ;Open the device
131 O NIO:(ZLISTEN=SOCK_":TCP":ATTACH="listener"):30:"SOCKET"
132 I '$T D LOG("Can't Open Socket: "_SOCK) Q
133 U NIO S NIO("ZISTCP",0)=$KEY D LOG("Have port.")
134 ;Start Listening
135 W /LISTEN(1) S NIO("ZISTCP",1)=$KEY D LOG("Start Listening. "_NIO("ZISTCP",1))
136 ;Wait for connection
137 S %A=0,POP=0 F D Q:%A!POP
138 . W /WAIT(30) ;Wait for connect
139 . I $P($KEY,"|",1)="CONNECT" S NIO("ZISTCP",2)=$KEY,%A=1
140 . S POP=$$EXIT
141 . Q
142 I POP C NIO Q
143 ;
144 S NIO("SOCK")=$P($G(NIO("ZISTCP",2)),"|",2)
145 D LOG("Got connection on "_NIO("SOCK"))
146 ;Close the main socket
147 C NIO:(SOCKET="listener")
148 ;Use the new socket
149 ;U NIO:(SOCKET=NIO("SOCK"):WIDTH=512:NOWRAP:IOERROR="TRAP":EXCEPT="G GTMERR^%ZISTCP")
150 U NIO:(SOCKET=NIO("SOCK"):WIDTH=512:NOWRAP:EXCEPT="G GTMERR^%ZISTCP")
151 S POP=0
152 Q
153 ;
154GTMERR ;The use will set this as a place to go on a IO error
155 S $ECODE=",U911,"
156 Q
157 ;
158EXIT() ;See if time to exit
159 I $$S^%ZTLOAD Q 1
160 N ZISQUIT S ZISQUIT=0
161 I $L(ZRULE) X ZRULE I $G(ZISQUIT) Q 1
162 Q 0
163 ;
164LAUNCH(IO,RTN) ;Run job for this conncetion.
165 N NIO,SOCK,EXIT,XQVOL
166 D VAR(IO)
167 S ^XUTL("XQ",$J,0)=$$DT^XLFDT
168 D LOG("Run "_RTN)
169 D @RTN
170 D LOG("Return from call, Exit="_$D(IO("C")))
171 Q $D(IO("C")) ;Use IO("C") to quit server
172 ;
173LOG(MSG) ;LOG STATUS
174 N CNT
175 S CNT=$G(^TMP("ZISTCP",$J))+1,^TMP("ZISTCP",$J)=CNT,^($J,CNT)=MSG
176 Q
177 ;
Note: See TracBrowser for help on using the repository browser.