- XMRTCP ;(WASH ISC)/THM/CAP-SMTP Receiver ;10/09/2002 14:23
- ;;8.0;MailMan;**7**;Jun 28, 2002
- ;Modified for TCP/IP under INET_SERVERS of Wollongong
- ;
- POLL ;Poll all domains with flags set
- ;Fake TaskMan Env.
- S U="^",X="ERR^XMRTCP",@^%ZOSF("TRAP"),XMDUZ=.5
- K XM S IOP="NULL",%IS=0 D ^%ZIS I '$D(IOT) S IOT=""
- HANG S IO(0)=IO,ZTQUEUED=$S($D(ZTQUEUED):ZTQUEUED,1:1),ZTSK=$S($D(ZTSK):ZTSK,1:"N/A"),XM="",XMLTCPT=""
- I $G(^TMP("XMRTCP",0)) S XMLTCPT=^(0) K ^(0)
- L Q:$P(^XMB(1,1,0),U,18)=1
- ;
- ;Any queues flagged (x-ref is set by TCP/IP POLL FLAG in domain file)
- S XMLTCPT=$O(^DIC(4.2,"ATCP",1,XMLTCPT)) G QQ:XMLTCPT=""
- S XMINST=XMLTCPT
- ;
- RQ ;Transmit messages / execute TURN command
- ;Are there messages to send ?
- I '$O(^XMB(3.7,.5,2,XMINST+1000,1,0)) G L
- ;Job out, if all slots full wait and try again.
- S %=$$CK(1) I '% S XMLTCPT=$O(^DIC(4.2,"ATCP",1,XMLTCPT),-1) H 60 G L
- D SETUP L +^XMBX("TCPCHAN",XMINST):3 E L -^XMBX("TCPCHAN-COUNT",%) G L
- ;
- S XMRTCP("CNT")=%
- ;
- ;Change name (prevent dupe error), then JOB myself
- Q:$E($G(XMRTCP("NAME")),1,6)="MM-FTP"
- S XMRTCP("NAME")="MM-TCP-"_XMINST D REN^XMRFTP
- S X=^%ZOSF("ERRTN"),@^%ZOSF("TRAP")
- ;
- ;Deliver messages
- ;
- ;INIT
- S XMSITE=$P(^DIC(4.2,XMINST,0),"^")
- D XMTCHECK^XMKPR(XMINST,.XMB)
- S XMOKTYPE("TCPCHAN")="" ;Find and use TCP/IP channel script
- D SCRIPT^XMKPR1(XMINST,XMSITE,.XMB,.XMOKTYPE) Q:'XMB("SCR IEN")
- ; Check that last try is at least 1 minute ago.
- ; If we've completed a cycle of scripts, wait until 1 hour has passed
- ; before we start the next cycle.
- I XMB("TRIES"),$$FMDIFF^XLFDT($$NOW^XLFDT,XMB("LAST TRY"),2)\60<1 G HALT
- E I XMB("ITERATIONS"),XMB("SCR IEN")=XMB("FIRST SCRIPT"),$$FMDIFF^XLFDT($$NOW^XLFDT,XMB("LAST TRY"),2)\60\60<1 G HALT
- S ZTIO=$P(XMB("SCRIPT"),U,5)
- D XMTAUDT^XMTDR(XMINST,.XMB)
- D ENT^XMC1
- H 30
- D KILL
- G HALT
- ;
- ;Pause between POLLINGS
- QQ D KILL S X=$H*86400+$P($H,",",2) G:$O(^XMBX(4.2995,0)) FTP^XMRFTP
- S X=22-($H*86400+$P($H,",",2)-X) I X>0 H X
- G POLL
- ;
- ;Entry on dupe name
- DUPNAME S X="ERR^XMRTCP",@^%ZOSF("TRAP") H 15 G L
- ;
- ;Clean up before next transmission
- KILL D KL1^XMC K DIC,XMB,XMDT,ZTPAR
- L Q
- ;
- SETUP ;Set up environment
- N IO S IO="",IO(0)="" D DT^DICRW
- Q
- ERR D @^%ZOSF("ERRTN") H 60
- I '$F(":MM-TCP:MM-FTP:",":"_$E($G(XMRTCP("NAME")),1,6)_":") D KILL G POLL
- HALT ;
- ;I ^%ZOSF("OS")["VAX" U IO:DISCONNECT
- ;G ^XUSCLEAN ; Writes to IO.
- G H2^XUSCLEAN ; Supposedly doesn't write to IO.
- ;
- ;Entry for Inet_servers interface RECEIVER
- ;SMTP service request invokes MailMan
- ;
- SOC25 S (XMRPORT,IO,IO(0))=%,X=$E(%_"-INETMM",1,15) D SETENV^%ZOSV
- D DT^DICRW,DUZ^XUP(.5)
- S X="ERR^ZU",@^%ZOSF("TRAP"),ER=0
- O IO:(SHARE,MAILBOX) U IO
- S XMCHAN="TCP/IP-MAILMAN",XMNO220=""
- D ENT^XMR
- G HALT
- ;
- ;Check if slot on TCP/IP to use
- CK(X) S I=$P(^XMB(1,1,0),"^",17)
- F %=1:1 L +^XMBX("TCPCHAN-COUNT",%):1 Q:$T Q:%=I
- Q $S($T:%,1:0)
- JOB ;
- H 90 ;wait for RVG mounts
- S $P(^XMB(1,1,0),"^",18)="" ;Clear the TCP/IP poller run flag
- START G START^XMRTCPGO
- ERRSCRPT ;TRAP transmission errors
- S ER=1
- I ^%ZOSF("OS")["VAX DSM" S $ECODE=""
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXMRTCP 3156 printed Jan 18, 2025@03:14:09 Page 2
- XMRTCP ;(WASH ISC)/THM/CAP-SMTP Receiver ;10/09/2002 14:23
- +1 ;;8.0;MailMan;**7**;Jun 28, 2002
- +2 ;Modified for TCP/IP under INET_SERVERS of Wollongong
- +3 ;
- POLL ;Poll all domains with flags set
- +1 ;Fake TaskMan Env.
- +2 SET U="^"
- SET X="ERR^XMRTCP"
- SET @^%ZOSF("TRAP")
- SET XMDUZ=.5
- +3 KILL XM
- SET IOP="NULL"
- SET %IS=0
- DO ^%ZIS
- IF '$DATA(IOT)
- SET IOT=""
- HANG SET IO(0)=IO
- SET ZTQUEUED=$SELECT($DATA(ZTQUEUED):ZTQUEUED,1:1)
- SET ZTSK=$SELECT($DATA(ZTSK):ZTSK,1:"N/A")
- SET XM=""
- SET XMLTCPT=""
- +1 IF $GET(^TMP("XMRTCP",0))
- SET XMLTCPT=^(0)
- KILL ^(0)
- L if $PIECE(^XMB(1,1,0),U,18)=1
- QUIT
- +1 ;
- +2 ;Any queues flagged (x-ref is set by TCP/IP POLL FLAG in domain file)
- +3 SET XMLTCPT=$ORDER(^DIC(4.2,"ATCP",1,XMLTCPT))
- if XMLTCPT=""
- GOTO QQ
- +4 SET XMINST=XMLTCPT
- +5 ;
- RQ ;Transmit messages / execute TURN command
- +1 ;Are there messages to send ?
- +2 IF '$ORDER(^XMB(3.7,.5,2,XMINST+1000,1,0))
- GOTO L
- +3 ;Job out, if all slots full wait and try again.
- +4 SET %=$$CK(1)
- IF '%
- SET XMLTCPT=$ORDER(^DIC(4.2,"ATCP",1,XMLTCPT),-1)
- HANG 60
- GOTO L
- +5 DO SETUP
- LOCK +^XMBX("TCPCHAN",XMINST):3
- IF '$TEST
- LOCK -^XMBX("TCPCHAN-COUNT",%)
- GOTO L
- +6 ;
- +7 SET XMRTCP("CNT")=%
- +8 ;
- +9 ;Change name (prevent dupe error), then JOB myself
- +10 if $EXTRACT($GET(XMRTCP("NAME")),1,6)="MM-FTP"
- QUIT
- +11 SET XMRTCP("NAME")="MM-TCP-"_XMINST
- DO REN^XMRFTP
- +12 SET X=^%ZOSF("ERRTN")
- SET @^%ZOSF("TRAP")
- +13 ;
- +14 ;Deliver messages
- +15 ;
- +16 ;INIT
- +17 SET XMSITE=$PIECE(^DIC(4.2,XMINST,0),"^")
- +18 DO XMTCHECK^XMKPR(XMINST,.XMB)
- +19 ;Find and use TCP/IP channel script
- SET XMOKTYPE("TCPCHAN")=""
- +20 DO SCRIPT^XMKPR1(XMINST,XMSITE,.XMB,.XMOKTYPE)
- if 'XMB("SCR IEN")
- QUIT
- +21 ; Check that last try is at least 1 minute ago.
- +22 ; If we've completed a cycle of scripts, wait until 1 hour has passed
- +23 ; before we start the next cycle.
- +24 IF XMB("TRIES")
- IF $$FMDIFF^XLFDT($$NOW^XLFDT,XMB("LAST TRY"),2)\60<1
- GOTO HALT
- +25 IF '$TEST
- IF XMB("ITERATIONS")
- IF XMB("SCR IEN")=XMB("FIRST SCRIPT")
- IF $$FMDIFF^XLFDT($$NOW^XLFDT,XMB("LAST TRY"),2)\60\60<1
- GOTO HALT
- +26 SET ZTIO=$PIECE(XMB("SCRIPT"),U,5)
- +27 DO XMTAUDT^XMTDR(XMINST,.XMB)
- +28 DO ENT^XMC1
- +29 HANG 30
- +30 DO KILL
- +31 GOTO HALT
- +32 ;
- +33 ;Pause between POLLINGS
- QQ DO KILL
- SET X=$HOROLOG*86400+$PIECE($HOROLOG,",",2)
- if $ORDER(^XMBX(4.2995,0))
- GOTO FTP^XMRFTP
- +1 SET X=22-($HOROLOG*86400+$PIECE($HOROLOG,",",2)-X)
- IF X>0
- HANG X
- +2 GOTO POLL
- +3 ;
- +4 ;Entry on dupe name
- DUPNAME SET X="ERR^XMRTCP"
- SET @^%ZOSF("TRAP")
- HANG 15
- GOTO L
- +1 ;
- +2 ;Clean up before next transmission
- KILL DO KL1^XMC
- KILL DIC,XMB,XMDT,ZTPAR
- +1 LOCK
- QUIT
- +2 ;
- SETUP ;Set up environment
- +1 NEW IO
- SET IO=""
- SET IO(0)=""
- DO DT^DICRW
- +2 QUIT
- ERR DO @^%ZOSF("ERRTN")
- HANG 60
- +1 IF '$FIND(":MM-TCP:MM-FTP:",":"_$EXTRACT($GET(XMRTCP("NAME")),1,6)_":")
- DO KILL
- GOTO POLL
- HALT ;
- +1 ;I ^%ZOSF("OS")["VAX" U IO:DISCONNECT
- +2 ;G ^XUSCLEAN ; Writes to IO.
- +3 ; Supposedly doesn't write to IO.
- GOTO H2^XUSCLEAN
- +4 ;
- +5 ;Entry for Inet_servers interface RECEIVER
- +6 ;SMTP service request invokes MailMan
- +7 ;
- SOC25 SET (XMRPORT,IO,IO(0))=%
- SET X=$EXTRACT(%_"-INETMM",1,15)
- DO SETENV^%ZOSV
- +1 DO DT^DICRW
- DO DUZ^XUP(.5)
- +2 SET X="ERR^ZU"
- SET @^%ZOSF("TRAP")
- SET ER=0
- +3 OPEN IO:(SHARE,MAILBOX)
- USE IO
- +4 SET XMCHAN="TCP/IP-MAILMAN"
- SET XMNO220=""
- +5 DO ENT^XMR
- +6 GOTO HALT
- +7 ;
- +8 ;Check if slot on TCP/IP to use
- CK(X) SET I=$PIECE(^XMB(1,1,0),"^",17)
- +1 FOR %=1:1
- LOCK +^XMBX("TCPCHAN-COUNT",%):1
- if $TEST
- QUIT
- if %=I
- QUIT
- +2 QUIT $SELECT($TEST:%,1:0)
- JOB ;
- +1 ;wait for RVG mounts
- HANG 90
- +2 ;Clear the TCP/IP poller run flag
- SET $PIECE(^XMB(1,1,0),"^",18)=""
- START GOTO START^XMRTCPGO
- ERRSCRPT ;TRAP transmission errors
- +1 SET ER=1
- +2 IF ^%ZOSF("OS")["VAX DSM"
- SET $ECODE=""
- +3 QUIT