| 1 | XMRTCP ;(WASH ISC)/THM/CAP-SMTP Receiver ;10/09/2002 14:23
|
|---|
| 2 | ;;8.0;MailMan;**7**;Jun 28, 2002
|
|---|
| 3 | ;Modified for TCP/IP under INET_SERVERS of Wollongong
|
|---|
| 4 | ;
|
|---|
| 5 | POLL ;Poll all domains with flags set
|
|---|
| 6 | ;Fake TaskMan Env.
|
|---|
| 7 | S U="^",X="ERR^XMRTCP",@^%ZOSF("TRAP"),XMDUZ=.5
|
|---|
| 8 | K XM S IOP="NULL",%IS=0 D ^%ZIS I '$D(IOT) S IOT=""
|
|---|
| 9 | HANG S IO(0)=IO,ZTQUEUED=$S($D(ZTQUEUED):ZTQUEUED,1:1),ZTSK=$S($D(ZTSK):ZTSK,1:"N/A"),XM="",XMLTCPT=""
|
|---|
| 10 | I $G(^TMP("XMRTCP",0)) S XMLTCPT=^(0) K ^(0)
|
|---|
| 11 | L Q:$P(^XMB(1,1,0),U,18)=1
|
|---|
| 12 | ;
|
|---|
| 13 | ;Any queues flagged (x-ref is set by TCP/IP POLL FLAG in domain file)
|
|---|
| 14 | S XMLTCPT=$O(^DIC(4.2,"ATCP",1,XMLTCPT)) G QQ:XMLTCPT=""
|
|---|
| 15 | S XMINST=XMLTCPT
|
|---|
| 16 | ;
|
|---|
| 17 | RQ ;Transmit messages / execute TURN command
|
|---|
| 18 | ;Are there messages to send ?
|
|---|
| 19 | I '$O(^XMB(3.7,.5,2,XMINST+1000,1,0)) G L
|
|---|
| 20 | ;Job out, if all slots full wait and try again.
|
|---|
| 21 | S %=$$CK(1) I '% S XMLTCPT=$O(^DIC(4.2,"ATCP",1,XMLTCPT),-1) H 60 G L
|
|---|
| 22 | D SETUP L +^XMBX("TCPCHAN",XMINST):3 E L -^XMBX("TCPCHAN-COUNT",%) G L
|
|---|
| 23 | ;
|
|---|
| 24 | S XMRTCP("CNT")=%
|
|---|
| 25 | ;
|
|---|
| 26 | ;Change name (prevent dupe error), then JOB myself
|
|---|
| 27 | Q:$E($G(XMRTCP("NAME")),1,6)="MM-FTP"
|
|---|
| 28 | S XMRTCP("NAME")="MM-TCP-"_XMINST D REN^XMRFTP
|
|---|
| 29 | S X=^%ZOSF("ERRTN"),@^%ZOSF("TRAP")
|
|---|
| 30 | ;
|
|---|
| 31 | ;Deliver messages
|
|---|
| 32 | ;
|
|---|
| 33 | ;INIT
|
|---|
| 34 | S XMSITE=$P(^DIC(4.2,XMINST,0),"^")
|
|---|
| 35 | D XMTCHECK^XMKPR(XMINST,.XMB)
|
|---|
| 36 | S XMOKTYPE("TCPCHAN")="" ;Find and use TCP/IP channel script
|
|---|
| 37 | D SCRIPT^XMKPR1(XMINST,XMSITE,.XMB,.XMOKTYPE) Q:'XMB("SCR IEN")
|
|---|
| 38 | ; Check that last try is at least 1 minute ago.
|
|---|
| 39 | ; If we've completed a cycle of scripts, wait until 1 hour has passed
|
|---|
| 40 | ; before we start the next cycle.
|
|---|
| 41 | I XMB("TRIES"),$$FMDIFF^XLFDT($$NOW^XLFDT,XMB("LAST TRY"),2)\60<1 G HALT
|
|---|
| 42 | E I XMB("ITERATIONS"),XMB("SCR IEN")=XMB("FIRST SCRIPT"),$$FMDIFF^XLFDT($$NOW^XLFDT,XMB("LAST TRY"),2)\60\60<1 G HALT
|
|---|
| 43 | S ZTIO=$P(XMB("SCRIPT"),U,5)
|
|---|
| 44 | D XMTAUDT^XMTDR(XMINST,.XMB)
|
|---|
| 45 | D ENT^XMC1
|
|---|
| 46 | H 30
|
|---|
| 47 | D KILL
|
|---|
| 48 | G HALT
|
|---|
| 49 | ;
|
|---|
| 50 | ;Pause between POLLINGS
|
|---|
| 51 | QQ D KILL S X=$H*86400+$P($H,",",2) G:$O(^XMBX(4.2995,0)) FTP^XMRFTP
|
|---|
| 52 | S X=22-($H*86400+$P($H,",",2)-X) I X>0 H X
|
|---|
| 53 | G POLL
|
|---|
| 54 | ;
|
|---|
| 55 | ;Entry on dupe name
|
|---|
| 56 | DUPNAME S X="ERR^XMRTCP",@^%ZOSF("TRAP") H 15 G L
|
|---|
| 57 | ;
|
|---|
| 58 | ;Clean up before next transmission
|
|---|
| 59 | KILL D KL1^XMC K DIC,XMB,XMDT,ZTPAR
|
|---|
| 60 | L Q
|
|---|
| 61 | ;
|
|---|
| 62 | SETUP ;Set up environment
|
|---|
| 63 | N IO S IO="",IO(0)="" D DT^DICRW
|
|---|
| 64 | Q
|
|---|
| 65 | ERR D @^%ZOSF("ERRTN") H 60
|
|---|
| 66 | I '$F(":MM-TCP:MM-FTP:",":"_$E($G(XMRTCP("NAME")),1,6)_":") D KILL G POLL
|
|---|
| 67 | HALT ;
|
|---|
| 68 | ;I ^%ZOSF("OS")["VAX" U IO:DISCONNECT
|
|---|
| 69 | ;G ^XUSCLEAN ; Writes to IO.
|
|---|
| 70 | G H2^XUSCLEAN ; Supposedly doesn't write to IO.
|
|---|
| 71 | ;
|
|---|
| 72 | ;Entry for Inet_servers interface RECEIVER
|
|---|
| 73 | ;SMTP service request invokes MailMan
|
|---|
| 74 | ;
|
|---|
| 75 | SOC25 S (XMRPORT,IO,IO(0))=%,X=$E(%_"-INETMM",1,15) D SETENV^%ZOSV
|
|---|
| 76 | D DT^DICRW,DUZ^XUP(.5)
|
|---|
| 77 | S X="ERR^ZU",@^%ZOSF("TRAP"),ER=0
|
|---|
| 78 | O IO:(SHARE,MAILBOX) U IO
|
|---|
| 79 | S XMCHAN="TCP/IP-MAILMAN",XMNO220=""
|
|---|
| 80 | D ENT^XMR
|
|---|
| 81 | G HALT
|
|---|
| 82 | ;
|
|---|
| 83 | ;Check if slot on TCP/IP to use
|
|---|
| 84 | CK(X) S I=$P(^XMB(1,1,0),"^",17)
|
|---|
| 85 | F %=1:1 L +^XMBX("TCPCHAN-COUNT",%):1 Q:$T Q:%=I
|
|---|
| 86 | Q $S($T:%,1:0)
|
|---|
| 87 | JOB ;
|
|---|
| 88 | H 90 ;wait for RVG mounts
|
|---|
| 89 | S $P(^XMB(1,1,0),"^",18)="" ;Clear the TCP/IP poller run flag
|
|---|
| 90 | START G START^XMRTCPGO
|
|---|
| 91 | ERRSCRPT ;TRAP transmission errors
|
|---|
| 92 | S ER=1
|
|---|
| 93 | I ^%ZOSF("OS")["VAX DSM" S $ECODE=""
|
|---|
| 94 | Q
|
|---|
