XMR ;ISC-SF/GMB-SMTP Receiver (RFC 821) ;09/24/2003 12:25
;;8.0;MailMan;**22**;Jun 28, 2002
ENT ; INITIALIZE
S ER=0
S XMC("NOREQUEUE")=1
D GET^XMCXT(0)
I '$D(XMC("BATCH")) S XMC("BATCH")=0
D OPEN^XML I ER!$G(POP) D Q
. D ^%ZISC:IO'=$G(IO(0)) W !,$C(7),$$EZBLD^DIALOG($S(ER:42227,1:37000)) ;Open failed / up-arrow out.
S:'$D(XM) XM=""
I XMC("BATCH") U IO
E D
. X ^%ZOSF("EOFF")
. S X=255
. X ^%ZOSF("RM"),^%ZOSF("TYPE-AHEAD")
S XMC("START")=$$TSTAMP^XMXUTIL1-.001
D RECEIVE
;I $G(XMINST) D XMTFINIS^XMTDR(XMINST)
Q
RECEIVE ; BEGINNING OF INTERPRETER
; The following variables are used in here only. They are not
; 'new'd because this routine may be called recursively via the
; TURN command, which alternates sending and receiving.
S XMC("DIR")="R"
D KILL
S XMEC=0,XMCONT="^HELP^NOOP^RSET^QUIT^VRFY^EXPN^STAT^CHRS^ECHO^"
D DOTRAN^XMC1(42300,$$FMTE^XLFDT(DT,5)) ;Transcript Date: |1|
S XMSTATE="^HELO^QUIT^"
I 'XMC("BATCH") D
. D BUFLUSH^XML
. W:'$D(XMNO220) 220
. H 2
. S XMSG="220 "_$G(^XMB("NETNAME"))_" MailMan "_$P($T(XMR+1),";",3)_" ready" X XMSEN
F D Q:ER!($G(XMCMD)="QUIT")!$G(XMC("QUIT"))
. D DOTRAN^XMC1(42301) ;Waiting for input
. S XMSTIME=300 X XMREC K XMSTIME Q:ER
. S XMP=XMRG
. F I=$C(9)," " F Q:XMP'[I S XMP=$P(XMP,I,1)_" "_$P(XMP,I,2,999) ; strip tabs / extra blanks
. S XMCMD=$$UP^XLFSTR($P(XMP," ")),XMP=$P(XMP," ",2,999)
. Q:XMCMD=""
. I XMSTATE_XMCONT'[(U_XMCMD_U) D ERRCMD Q
. I $T(@XMCMD)="" S XMSG="502 Command not implemented" X XMSEN Q
. D @XMCMD
I $G(XMCMD)="QUIT"!ER,$G(XMZ) D ZAPIT^XMXMSGS2(.5,.95,XMZ)
S:$G(XMINST) $P(^XMBS(4.2999,XMINST,3),U,1,6)="^^^^^"
D KILL
Q
KILL ;
K I,X,XMC("HELO RECV"),XMCMD,XMCONT,XMEC,XMINSTR,XMNVFROM,XMP
K XMREMID,XMRXMZ,XMRVAL,XMSTATE,XM2LONG,XMZ,XMZFDA,XMZIENS
K XMERR,^TMP("XMERR",$J)
Q
CHRS ;;Christen this domain syntax: CHRS <parent>,<child>
N XMPARENT,XMCHILD,X,Y,DIC
S XMPARENT=$P(XMP,",",1),XMCHILD=$P(XMP,",",2)
S X=XMPARENT
S DIC=4.2,DIC(0)="MF"
D ^DIC
I +Y'=$P(^XMB(1,1,0),U,3) S XMSG="550 Parent name does not match locally initialized parent name" X XMSEN Q
S X=XMCHILD
S DIC=4.2
D ^DIC
I +Y'=$P(^XMB(1,1,0),U,1) S XMSG="550 Child name does not match locally initialized domain name" X XMSEN Q
S ^XMB("NETNAME")=$P(Y,U,2)
S $P(^XMB(1,1,0),U,4)=DT
S XMSG="250 Local domain "_$P(Y,U,2)_" successfully christened by parent "_XMPARENT X XMSEN
Q
DATA ;;TEXT / ASSUMES VALID RECIPIENT
D DATA^XMR3
Q
ECHO ;;ECHO TEST
S XMSG="314 Echo mode. Received messages will be echoed until a single period is received" X XMSEN Q:ER
F X XMREC Q:ER Q:XMRG="." S XMSG=XMRG X XMSEN Q:ER
Q:ER
S XMSG="250 End of echo mode" X XMSEN
Q
EXPN ;;EXPAND MAILING LIST
N XMIEN,XMPTR,XMCNT,XMNETNAM,Y,X,DIC
S X=XMP
I X["<" S X=$P($P(X,"<",2),">")
I "^G.^g.^"[(U_$E(X,1,2)_U) S X=$E(X,3,999)
S DIC="^XMB(3.8,",DIC(0)="MF"
D ^DIC I Y<0 S XMSG="550 mail group not found" X XMSEN Q
S XMIEN=+Y,XMCNT=0,XMNETNAM=^XMB("NETNAME"),XMPTR=""
F S XMPTR=$O(^XMB(3.8,XMIEN,1,"B",XMPTR)) Q:'XMPTR D Q:ER
. Q:'$D(^VA(200,XMPTR,0))
. S XMCNT=XMCNT+1
. S XMSG="250 <"_$TR($$NAME^XMXUTIL(XMPTR),". ,","+_.")_"@"_XMNETNAM_">" X XMSEN
I 'XMCNT S XMSG="250 No LOCAL members in group" X XMSEN Q:ER
S XMSG="250 List SHOWS local members only, not member groups, remote members or distribution lists." X XMSEN
Q
HELO ;;HELO COMMAND
D HELO^XMR1
Q
HELP ;;DISPLAY HELP MESSAGE
D HELPME^XMR4
Q
MAIL ;;START
D:$D(XMRVAL) VALSET^XMR1(XMINST,.XMRVAL)
D MAIL^XMR1
Q
MESS ;;
D MESS^XMR2
Q
NOOP ;;NO OPERATION FOR TESTING
S XMSG="250 OK" X XMSEN
Q
QUIT ;;
D:$D(XMRVAL) VALSET^XMR1(XMINST,.XMRVAL)
S XMSG="221 "_$G(^XMB("NETNAME"))_" Service closing transmission channel" X XMSEN
S XMC("QUIT")=1
Q
RCPT ;;
D RCPT^XMR1
Q
RSET ;;RESET STATE TABLES
N X,XMI,Y,DIC
I $G(XMZ) D
. I $D(^XMB(3.9,XMZ,0)),'$D(^XMB(3.9,XMZ,1,0)) D KILLMSG^XMXUTIL(XMZ)
. I $D(^XMB(3.7,.5,2,.95,1,XMZ)) D ZAPIT^XMXMSGS2(.5,.95,XMZ)
S XMSTATE="HELO^MAIL^"
K XMZ,XMZFDA,XMZIENS,^TMP("XMY",$J),^TMP("XMY0",$J)
S XMSG="250" X XMSEN Q
Q
STAT ;;
N K,I,J
I $G(XMNVFROM)'="" S XMSG="211-Current reverse path is: "_XMNVFROM X XMSEN Q:ER
I $G(XMINST)'="" S XMSG="211-Current sender is: "_$P(^DIC(4.2,XMINST,0),U) X XMSEN Q:ER
S XMSG="211-Acceptable commands at the moment are: " X XMSEN Q:ER
S XMSG="211-"
S K=XMSTATE_XMCONT F I=1:1:$L(K,U) S J=$P(K,U,I) I J'="" S XMSG=XMSG_J_" "
X XMSEN Q:ER
I $D(XMZ),$O(^XMB(3.9,XMZ,2,0))>0 D Q:ER
. S J=0
. S XMSG="211-Current text buffer is:" X XMSEN Q:ER
. F S J=$O(^XMB(3.9,XMZ,2,J)) Q:J'>0 S XMSG="211-"_J_" "_^(J,0) X XMSEN Q:ER
Q:ER
I $O(^TMP("XMY",$J,""))'="" D Q:ER
. S J=""
. S XMSG="211-Current recipients are: " X XMSEN Q:ER
. F S J=$O(^TMP("XMY",$J,J)) Q:J="" S XMSG="211-"_$S('J:J,1:$$NAME^XMXUTIL(J)) X XMSEN Q:ER
Q:ER
S XMSG="211 OK" X XMSEN
Q
TURN ;;
D:$D(XMRVAL) VALSET^XMR1(XMINST,.XMRVAL)
;TURN AROUND PROTOCOL
I $F("Yy",$P(^DIC(4.2,XMINST,0),U,16))>1 S XMSG="502 "_^XMB("NETNAME")_" has TURN disabled." X XMSEN Q
I '$O(^XMB(3.7,.5,2,XMINST+1000,1,0)) S XMSG="502 "_^XMB("NETNAME")_" has no messages to export" X XMSEN Q
I $P(^DIC(4.2,XMINST,0),U)'=$G(XMC("HELO RECV")) S XMSG="502 TURN command rejected." X XMSEN Q
S XMSG="250 "_^XMB("NETNAME")_" has messages to export" X XMSEN Q:ER
D KILL
G SEND^XMS
VRFY ;;VERIFY USER EXISTS
N XMNAME
S XMINSTR("ADDR FLAGS")="X" ; Do not expand
S XMNAME=$$LOOKUP^XMR1(XMP,.XMINSTR)
K XMINSTR("ADDR FLAGS")
Q:XMNAME=0
S XMSG="250 "_XMNAME_" <"_$TR(Y,". ,","+_.")_"@"_^XMB("NETNAME")_">" X XMSEN
Q
ERRCMD ;
S XMEC=XMEC+1
I XMEC>9 S ER=1,XMSG="500 too many errors or fatal error, closing channel"
E S XMSG="500 Syntax error, command ("_XMCMD_") out of sequence, or unrecognized command"
X XMSEN
Q
TST ;
S XM="",XMC("BATCH")=0,XMC("DX")=1,XMCHAN="TEST"
D OPEN^XML
D RECEIVE
D KILL^XMC
Q
DECNET ; Task-Task Communications
I $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D R^XMCTRAP"
E S X="R^XMCTRAP",@^%ZOSF("TRAP")
S (IO,I0(0))="SYS$NET",XMCHAN="DECNET" D DT^DICRW O IO U IO
G ENT
XMR ;ISC-SF/GMB-SMTP Receiver (RFC 821) ;09/24/2003 12:25
+1 ;;8.0;MailMan;**22**;Jun 28, 2002
ENT ; INITIALIZE
+1 SET ER=0
+2 SET XMC("NOREQUEUE")=1
+3 DO GET^XMCXT(0)
+4 IF '$DATA(XMC("BATCH"))
SET XMC("BATCH")=0
+5 DO OPEN^XML
IF ER!$GET(POP)
Begin DoDot:1
+6 ;Open failed / up-arrow out.
IF IO'=$GET(IO(0))
DO ^%ZISC
WRITE !,$CHAR(7),$$EZBLD^DIALOG($SELECT(ER:42227,1:37000))
End DoDot:1
QUIT
+7 IF '$DATA(XM)
SET XM=""
+8 IF XMC("BATCH")
USE IO
+9 IF '$TEST
Begin DoDot:1
+10 XECUTE ^%ZOSF("EOFF")
+11 SET X=255
+12 XECUTE ^%ZOSF("RM")
XECUTE ^%ZOSF("TYPE-AHEAD")
End DoDot:1
+13 SET XMC("START")=$$TSTAMP^XMXUTIL1-.001
+14 DO RECEIVE
+15 ;I $G(XMINST) D XMTFINIS^XMTDR(XMINST)
+16 QUIT
RECEIVE ; BEGINNING OF INTERPRETER
+1 ; The following variables are used in here only. They are not
+2 ; 'new'd because this routine may be called recursively via the
+3 ; TURN command, which alternates sending and receiving.
+4 SET XMC("DIR")="R"
+5 DO KILL
+6 SET XMEC=0
SET XMCONT="^HELP^NOOP^RSET^QUIT^VRFY^EXPN^STAT^CHRS^ECHO^"
+7 ;Transcript Date: |1|
DO DOTRAN^XMC1(42300,$$FMTE^XLFDT(DT,5))
+8 SET XMSTATE="^HELO^QUIT^"
+9 IF 'XMC("BATCH")
Begin DoDot:1
+10 DO BUFLUSH^XML
+11 IF '$DATA(XMNO220)
WRITE 220
+12 HANG 2
+13 SET XMSG="220 "_$GET(^XMB("NETNAME"))_" MailMan "_$PIECE($TEXT(XMR+1),";",3)_" ready"
XECUTE XMSEN
End DoDot:1
+14 FOR
Begin DoDot:1
+15 ;Waiting for input
DO DOTRAN^XMC1(42301)
+16 SET XMSTIME=300
XECUTE XMREC
KILL XMSTIME
IF ER
QUIT
+17 SET XMP=XMRG
+18 ; strip tabs / extra blanks
FOR I=$CHAR(9)," "
FOR
IF XMP'[I
QUIT
SET XMP=$PIECE(XMP,I,1)_" "_$PIECE(XMP,I,2,999)
+19 SET XMCMD=$$UP^XLFSTR($PIECE(XMP," "))
SET XMP=$PIECE(XMP," ",2,999)
+20 IF XMCMD=""
QUIT
+21 IF XMSTATE_XMCONT'[(U_XMCMD_U)
DO ERRCMD
QUIT
+22 IF $TEXT(@XMCMD)=""
SET XMSG="502 Command not implemented"
XECUTE XMSEN
QUIT
+23 DO @XMCMD
End DoDot:1
IF ER!($GET(XMCMD)="QUIT")!$GET(XMC("QUIT"))
QUIT
+24 IF $GET(XMCMD)="QUIT"!ER
IF $GET(XMZ)
DO ZAPIT^XMXMSGS2(.5,.95,XMZ)
+25 IF $GET(XMINST)
SET $PIECE(^XMBS(4.2999,XMINST,3),U,1,6)="^^^^^"
+26 DO KILL
+27 QUIT
KILL ;
+1 KILL I,X,XMC("HELO RECV"),XMCMD,XMCONT,XMEC,XMINSTR,XMNVFROM,XMP
+2 KILL XMREMID,XMRXMZ,XMRVAL,XMSTATE,XM2LONG,XMZ,XMZFDA,XMZIENS
+3 KILL XMERR,^TMP("XMERR",$JOB)
+4 QUIT
CHRS ;;Christen this domain syntax: CHRS <parent>,<child>
+1 NEW XMPARENT,XMCHILD,X,Y,DIC
+2 SET XMPARENT=$PIECE(XMP,",",1)
SET XMCHILD=$PIECE(XMP,",",2)
+3 SET X=XMPARENT
+4 SET DIC=4.2
SET DIC(0)="MF"
+5 DO ^DIC
+6 IF +Y'=$PIECE(^XMB(1,1,0),U,3)
SET XMSG="550 Parent name does not match locally initialized parent name"
XECUTE XMSEN
QUIT
+7 SET X=XMCHILD
+8 SET DIC=4.2
+9 DO ^DIC
+10 IF +Y'=$PIECE(^XMB(1,1,0),U,1)
SET XMSG="550 Child name does not match locally initialized domain name"
XECUTE XMSEN
QUIT
+11 SET ^XMB("NETNAME")=$PIECE(Y,U,2)
+12 SET $PIECE(^XMB(1,1,0),U,4)=DT
+13 SET XMSG="250 Local domain "_$PIECE(Y,U,2)_" successfully christened by parent "_XMPARENT
XECUTE XMSEN
+14 QUIT
DATA ;;TEXT / ASSUMES VALID RECIPIENT
+1 DO DATA^XMR3
+2 QUIT
ECHO ;;ECHO TEST
+1 SET XMSG="314 Echo mode. Received messages will be echoed until a single period is received"
XECUTE XMSEN
IF ER
QUIT
+2 FOR
XECUTE XMREC
IF ER
QUIT
IF XMRG="."
QUIT
SET XMSG=XMRG
XECUTE XMSEN
IF ER
QUIT
+3 IF ER
QUIT
+4 SET XMSG="250 End of echo mode"
XECUTE XMSEN
+5 QUIT
EXPN ;;EXPAND MAILING LIST
+1 NEW XMIEN,XMPTR,XMCNT,XMNETNAM,Y,X,DIC
+2 SET X=XMP
+3 IF X["<"
SET X=$PIECE($PIECE(X,"<",2),">")
+4 IF "^G.^g.^"[(U_$EXTRACT(X,1,2)_U)
SET X=$EXTRACT(X,3,999)
+5 SET DIC="^XMB(3.8,"
SET DIC(0)="MF"
+6 DO ^DIC
IF Y<0
SET XMSG="550 mail group not found"
XECUTE XMSEN
QUIT
+7 SET XMIEN=+Y
SET XMCNT=0
SET XMNETNAM=^XMB("NETNAME")
SET XMPTR=""
+8 FOR
SET XMPTR=$ORDER(^XMB(3.8,XMIEN,1,"B",XMPTR))
IF 'XMPTR
QUIT
Begin DoDot:1
+9 IF '$DATA(^VA(200,XMPTR,0))
QUIT
+10 SET XMCNT=XMCNT+1
+11 SET XMSG="250 <"_$TRANSLATE($$NAME^XMXUTIL(XMPTR),". ,","+_.")_"@"_XMNETNAM_">"
XECUTE XMSEN
End DoDot:1
IF ER
QUIT
+12 IF 'XMCNT
SET XMSG="250 No LOCAL members in group"
XECUTE XMSEN
IF ER
QUIT
+13 SET XMSG="250 List SHOWS local members only, not member groups, remote members or distribution lists."
XECUTE XMSEN
+14 QUIT
HELO ;;HELO COMMAND
+1 DO HELO^XMR1
+2 QUIT
HELP ;;DISPLAY HELP MESSAGE
+1 DO HELPME^XMR4
+2 QUIT
MAIL ;;START
+1 IF $DATA(XMRVAL)
DO VALSET^XMR1(XMINST,.XMRVAL)
+2 DO MAIL^XMR1
+3 QUIT
MESS ;;
+1 DO MESS^XMR2
+2 QUIT
NOOP ;;NO OPERATION FOR TESTING
+1 SET XMSG="250 OK"
XECUTE XMSEN
+2 QUIT
QUIT ;;
+1 IF $DATA(XMRVAL)
DO VALSET^XMR1(XMINST,.XMRVAL)
+2 SET XMSG="221 "_$GET(^XMB("NETNAME"))_" Service closing transmission channel"
XECUTE XMSEN
+3 SET XMC("QUIT")=1
+4 QUIT
RCPT ;;
+1 DO RCPT^XMR1
+2 QUIT
RSET ;;RESET STATE TABLES
+1 NEW X,XMI,Y,DIC
+2 IF $GET(XMZ)
Begin DoDot:1
+3 IF $DATA(^XMB(3.9,XMZ,0))
IF '$DATA(^XMB(3.9,XMZ,1,0))
DO KILLMSG^XMXUTIL(XMZ)
+4 IF $DATA(^XMB(3.7,.5,2,.95,1,XMZ))
DO ZAPIT^XMXMSGS2(.5,.95,XMZ)
End DoDot:1
+5 SET XMSTATE="HELO^MAIL^"
+6 KILL XMZ,XMZFDA,XMZIENS,^TMP("XMY",$JOB),^TMP("XMY0",$JOB)
+7 SET XMSG="250"
XECUTE XMSEN
QUIT
+8 QUIT
STAT ;;
+1 NEW K,I,J
+2 IF $GET(XMNVFROM)'=""
SET XMSG="211-Current reverse path is: "_XMNVFROM
XECUTE XMSEN
IF ER
QUIT
+3 IF $GET(XMINST)'=""
SET XMSG="211-Current sender is: "_$PIECE(^DIC(4.2,XMINST,0),U)
XECUTE XMSEN
IF ER
QUIT
+4 SET XMSG="211-Acceptable commands at the moment are: "
XECUTE XMSEN
IF ER
QUIT
+5 SET XMSG="211-"
+6 SET K=XMSTATE_XMCONT
FOR I=1:1:$LENGTH(K,U)
SET J=$PIECE(K,U,I)
IF J'=""
SET XMSG=XMSG_J_" "
+7 XECUTE XMSEN
IF ER
QUIT
+8 IF $DATA(XMZ)
IF $ORDER(^XMB(3.9,XMZ,2,0))>0
Begin DoDot:1
+9 SET J=0
+10 SET XMSG="211-Current text buffer is:"
XECUTE XMSEN
IF ER
QUIT
+11 FOR
SET J=$ORDER(^XMB(3.9,XMZ,2,J))
IF J'>0
QUIT
SET XMSG="211-"_J_" "_^(J,0)
XECUTE XMSEN
IF ER
QUIT
End DoDot:1
IF ER
QUIT
+12 IF ER
QUIT
+13 IF $ORDER(^TMP("XMY",$JOB,""))'=""
Begin DoDot:1
+14 SET J=""
+15 SET XMSG="211-Current recipients are: "
XECUTE XMSEN
IF ER
QUIT
+16 FOR
SET J=$ORDER(^TMP("XMY",$JOB,J))
IF J=""
QUIT
SET XMSG="211-"_$SELECT('J:J,1:$$NAME^XMXUTIL(J))
XECUTE XMSEN
IF ER
QUIT
End DoDot:1
IF ER
QUIT
+17 IF ER
QUIT
+18 SET XMSG="211 OK"
XECUTE XMSEN
+19 QUIT
TURN ;;
+1 IF $DATA(XMRVAL)
DO VALSET^XMR1(XMINST,.XMRVAL)
+2 ;TURN AROUND PROTOCOL
+3 IF $FIND("Yy",$PIECE(^DIC(4.2,XMINST,0),U,16))>1
SET XMSG="502 "_^XMB("NETNAME")_" has TURN disabled."
XECUTE XMSEN
QUIT
+4 IF '$ORDER(^XMB(3.7,.5,2,XMINST+1000,1,0))
SET XMSG="502 "_^XMB("NETNAME")_" has no messages to export"
XECUTE XMSEN
QUIT
+5 IF $PIECE(^DIC(4.2,XMINST,0),U)'=$GET(XMC("HELO RECV"))
SET XMSG="502 TURN command rejected."
XECUTE XMSEN
QUIT
+6 SET XMSG="250 "_^XMB("NETNAME")_" has messages to export"
XECUTE XMSEN
IF ER
QUIT
+7 DO KILL
+8 GOTO SEND^XMS
VRFY ;;VERIFY USER EXISTS
+1 NEW XMNAME
+2 ; Do not expand
SET XMINSTR("ADDR FLAGS")="X"
+3 SET XMNAME=$$LOOKUP^XMR1(XMP,.XMINSTR)
+4 KILL XMINSTR("ADDR FLAGS")
+5 IF XMNAME=0
QUIT
+6 SET XMSG="250 "_XMNAME_" <"_$TRANSLATE(Y,". ,","+_.")_"@"_^XMB("NETNAME")_">"
XECUTE XMSEN
+7 QUIT
ERRCMD ;
+1 SET XMEC=XMEC+1
+2 IF XMEC>9
SET ER=1
SET XMSG="500 too many errors or fatal error, closing channel"
+3 IF '$TEST
SET XMSG="500 Syntax error, command ("_XMCMD_") out of sequence, or unrecognized command"
+4 XECUTE XMSEN
+5 QUIT
TST ;
+1 SET XM=""
SET XMC("BATCH")=0
SET XMC("DX")=1
SET XMCHAN="TEST"
+2 DO OPEN^XML
+3 DO RECEIVE
+4 DO KILL^XMC
+5 QUIT
DECNET ; Task-Task Communications
+1 IF $$NEWERR^%ZTER
NEW $ETRAP,$ESTACK
SET $ETRAP="D R^XMCTRAP"
+2 IF '$TEST
SET X="R^XMCTRAP"
SET @^%ZOSF("TRAP")
+3 SET (IO,I0(0))="SYS$NET"
SET XMCHAN="DECNET"
DO DT^DICRW
OPEN IO
USE IO
+4 GOTO ENT
