XMA21A ;(WASH ISC)/CAP-MailMan name server (CONT) ;07/10/96 10:04 [ 12/06/96 4:51 PM ]
;;7.1;Mailman;**1003**;OCT 27, 1998
;;7.1;MailMan;**4,30**;Jun 02, 1994
Q
INST ;Check domain
S:$E(X)="<" X=$E(X,2,999) S X=$P(X,">"),X1=X,%Z=""
F %="INFO:","I:","CC:" I X[% S %Z=%,X=$P(X,%,2)
I "G."=$E(X,1,2)!($E(X,1,2)="g.") S XMR=$S($D(XMR):XMR,'$D(XMZ):"",$D(^XMB(3.9,XMZ,0)):^(0),1:"") I $S($D(XMDUZ):XMDUZ,1:DUZ)'=$P(XMR,U,2),$P(XMR,U,7)["P",'$D(XMCHAN) K %Z G ER^XMA21G
S X1=X,X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ"),X=$P(X,"@",2)
2 I X'=^XMB("NETNAME") S X1=%Z_X1 G 3
S Y=^XMB("NUM")
I $P(X1,"@")'["%" S X1=%Z_X1 G LOCAL
S X1=$TR(X1,"._+",", .")
S Y=$P(X1,"@"),X=$P(Y,"%",$L(Y,"%")),X1=$P(Y,"%",1,$L(Y,"%")-1)_"@"_X
G 2
3 S DIC="^DIC(4.2,",DIC(0)="ZM"_$E("E",$D(XMLOC)) D I2 Q:Y<0 S $P(Y(0),U)=$S('$D(X9):$P(X,"@",2),$L(X9):X9_"."_X,1:$P(Y,U,2)) K X9
I $P(X1,"@")="" S XMMG="Missing recipient name" S Y=-1 Q
I '$D(^XMB("NUM")) S XMMG="This domain not christened" S Y=-1 Q
I $L(X1,".")=1 D IHS I Y=-1 Q ;IHS/MFD added line and IHS subroutine
I +Y=^XMB("NUM") G LOCAL
I '$D(XMDF),$P(Y(0),U,2)["C",$P(Y(0),U,2)'["S" S XMMG="MailMan access to "_$P(Y,U,2)_" closed." S Y=-1 Q
I '$D(XMDF),$P(Y(0),U,11)'="",'$D(^XUSEC($P(Y(0),U,11),DUZ)) S XMMG="You don't hold this domain's KEY.",Y=-1 Q
I '$D(XMDF),$P(Y(0),U,2)["N" S XMMG="NO forwarding to this domain.",Y=-1 Q
S %=$P(Y(0),U)
I $TR(%,"()<>@,;:\[]"_$C(34),"")'=% S XMMG="Domain name must not contain punctuation other than hyphens or dots.",Y=-1 Q
I %'?1A.E1AN S XMMG="Domain name must begin with a letter and end with a letter or number.",Y=-1 Q
I $G(XMZ),$$NO(XMZ) W:'$D(ZTQUEUED) *7 S XMMG="<< Messages longer than "_$$NO(XMZ)_" lines may NOT be sent across the network. >>",Y=-1 Q
;
S Y1=$P(X1,"@")_"@"_%
I $L(Y1)>104!($L($P(Y1,"@")_Y(0,0))>103) S Y=-1,XMMG="Address parsing unsuccessful !" Q
G I:$G(XMN)
;Add RCPT (XMN is either zero or undefined)
D PSP^XMA210 S ^TMP("XMY",$J,$S('$D(^DIC(4.2,"C",$P(Y1,"@",2))):Y1,1:$P(Y1,"@")_"@"_Y(0,0)))=+Y
I '$D(XMA21G) S ^TMP("XMY0",$J,Y1)=""
Q:$D(XMCHAN)
;
;Display for interactive users (XMCHAN not defined above)
S XMMG="via "_$P(^DIC(4.2,+Y,0),U)_$S($P(^(0),U,2)["S":"",1:" (Queued)")
S XMQ(+Y)="" Q
;Remove RCPT
I Q:'$D(^TMP("XMY",$J,Y1)) K ^TMP("XMY",$J,Y1),^TMP("XMY0",$J,Y1) W " Deleted."
Q
I2 S X9="",XMA21A=^XMB("NUM") I $L(X,".")>1!$D(XMCHAN) S %Z=$P(X,".",$L(X,".")) I %Z="MIL"!(%Z="DE") S DIC(0)=DIC(0)_"MXO"
F D ^DIC Q:$S(Y-XMA21A=0&'$L(X9):1,Y-XMA21A'=0&(Y>0):1,1:0) D Q:'$D(XMA21A)
. I X=^XMB("NETNAME") D Q
. . S Y=-1,XMDOMLK=1 ; XMDOMLK is checked only by ^XMR.
. . S XMMG="Sub-Domain '"_X9_"' not found."
. . K XMA21A
. S X9=X9_$S($L(X9):".",1:"")_$P(X,".")
. S X=$P(X,".",2,999)
. I X="" K XMA21A S:$E(X9)'="#" XMMG="Domain not found." Q
. ;I $L(X9,".")>1,X'?.E1".".E,DIC(0)'["X" S DIC(0)=DIC(0)_"X" ; *** WHY?
I '$D(XMA21A),$E(X9)="#" G I3
Q
;X400 ADDRESSING
I3 S X="#" D ^DIC I Y>0 K X9 S X=X1 Q
S XMMG="X.400 DOMAIN not found. MUST HAVE '#' as it's SYNONYM" Q
LOCAL ;Recipient is local
;Recipient name
S X=$P(X1,"@")
;Call Local Name Server Y>0=success
D W3 S X=$P(X1,"@")
Q:$S(Y>0:1,".D.G.S.d.g.s."[$E(X_" ",1,2):1,X'[".":1,1:0)
;If not successful first time, convert first "," to "." - try again
S X=$TR(X,"._+",", ."),XMMG=""
G W3GO
W3 N %,XMA21AL S %=X1,XMA21AL=1 N X1 S X1=%
W3GO N XMLOCQ S XMLOCQ="QUIT" D W3^XMA21
Q
NO(X) ;Do not allow message to be sent across network if too long
;according to field 8.3 of file 4.3
I $S($D(XMCHAN):1,$D(XMDF):1,$D(^XUSEC("XMMGR",DUZ)):1,1:0) Q 0
N % S %=$P($G(^XMB(1,1,"NETWORK-LIMIT")),U),%=$S(%:%,1:2000)
I $P($G(^XMB(3.9,X,2,0)),U,4)>% Q %
Q 0
IHS ; IHS/MFD screen out addressing to just user@COM, etc.
N XBIHS F XBIHS="COM","GOV","ARPA","NET","ORG","UK","BITNET","UUCP","FI","ZA","CA","MIL" I X=XBIHS S XMMG="No addressing to "_X_" domain." S Y=-1 Q ;IHS/MFD
XMA21A ;(WASH ISC)/CAP-MailMan name server (CONT) ;07/10/96 10:04 [ 12/06/96 4:51 PM ]
+1 ;;7.1;Mailman;**1003**;OCT 27, 1998
+2 ;;7.1;MailMan;**4,30**;Jun 02, 1994
+3 QUIT
INST ;Check domain
+1 IF $EXTRACT(X)="<"
SET X=$EXTRACT(X,2,999)
SET X=$PIECE(X,">")
SET X1=X
SET %Z=""
+2 FOR %="INFO:","I:","CC:"
IF X[%
SET %Z=%
SET X=$PIECE(X,%,2)
+3 IF "G."=$EXTRACT(X,1,2)!($EXTRACT(X,1,2)="g.")
SET XMR=$SELECT($DATA(XMR):XMR,'$DATA(XMZ):"",$DATA(^XMB(3.9,XMZ,0)):^(0),1:"")
IF $SELECT($DATA(XMDUZ):XMDUZ,1:DUZ)'=$PIECE(XMR,U,2)
IF $PIECE(XMR,U,7)["P"
IF '$DATA(XMCHAN)
KILL %Z
GOTO ER^XMA21G
+4 SET X1=X
SET X=$TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
SET X=$PIECE(X,"@",2)
2 IF X'=^XMB("NETNAME")
SET X1=%Z_X1
GOTO 3
+1 SET Y=^XMB("NUM")
+2 IF $PIECE(X1,"@")'["%"
SET X1=%Z_X1
GOTO LOCAL
+3 SET X1=$TRANSLATE(X1,"._+",", .")
+4 SET Y=$PIECE(X1,"@")
SET X=$PIECE(Y,"%",$LENGTH(Y,"%"))
SET X1=$PIECE(Y,"%",1,$LENGTH(Y,"%")-1)_"@"_X
+5 GOTO 2
3 SET DIC="^DIC(4.2,"
SET DIC(0)="ZM"_$EXTRACT("E",$DATA(XMLOC))
DO I2
IF Y<0
QUIT
SET $PIECE(Y(0),U)=$SELECT('$DATA(X9):$PIECE(X,"@",2),$LENGTH(X9):X9_"."_X,1:$PIECE(Y,U,2))
KILL X9
+1 IF $PIECE(X1,"@")=""
SET XMMG="Missing recipient name"
SET Y=-1
QUIT
+2 IF '$DATA(^XMB("NUM"))
SET XMMG="This domain not christened"
SET Y=-1
QUIT
+3 ;IHS/MFD added line and IHS subroutine
IF $LENGTH(X1,".")=1
DO IHS
IF Y=-1
QUIT
+4 IF +Y=^XMB("NUM")
GOTO LOCAL
+5 IF '$DATA(XMDF)
IF $PIECE(Y(0),U,2)["C"
IF $PIECE(Y(0),U,2)'["S"
SET XMMG="MailMan access to "_$PIECE(Y,U,2)_" closed."
SET Y=-1
QUIT
+6 IF '$DATA(XMDF)
IF $PIECE(Y(0),U,11)'=""
IF '$DATA(^XUSEC($PIECE(Y(0),U,11),DUZ))
SET XMMG="You don't hold this domain's KEY."
SET Y=-1
QUIT
+7 IF '$DATA(XMDF)
IF $PIECE(Y(0),U,2)["N"
SET XMMG="NO forwarding to this domain."
SET Y=-1
QUIT
+8 SET %=$PIECE(Y(0),U)
+9 IF $TRANSLATE(%,"()<>@,;:\[]"_$CHAR(34),"")'=%
SET XMMG="Domain name must not contain punctuation other than hyphens or dots."
SET Y=-1
QUIT
+10 IF %'?1A.E1AN
SET XMMG="Domain name must begin with a letter and end with a letter or number."
SET Y=-1
QUIT
+11 IF $GET(XMZ)
IF $$NO(XMZ)
IF '$DATA(ZTQUEUED)
WRITE *7
SET XMMG="<< Messages longer than "_$$NO(XMZ)_" lines may NOT be sent across the network. >>"
SET Y=-1
QUIT
+12 ;
+13 SET Y1=$PIECE(X1,"@")_"@"_%
+14 IF $LENGTH(Y1)>104!($LENGTH($PIECE(Y1,"@")_Y(0,0))>103)
SET Y=-1
SET XMMG="Address parsing unsuccessful !"
QUIT
+15 IF $GET(XMN)
GOTO I
+16 ;Add RCPT (XMN is either zero or undefined)
+17 DO PSP^XMA210
SET ^TMP("XMY",$JOB,$SELECT('$DATA(^DIC(4.2,"C",$PIECE(Y1,"@",2))):Y1,1:$PIECE(Y1,"@")_"@"_Y(0,0)))=+Y
+18 IF '$DATA(XMA21G)
SET ^TMP("XMY0",$JOB,Y1)=""
+19 IF $DATA(XMCHAN)
QUIT
+20 ;
+21 ;Display for interactive users (XMCHAN not defined above)
+22 SET XMMG="via "_$PIECE(^DIC(4.2,+Y,0),U)_$SELECT($PIECE(^(0),U,2)["S":"",1:" (Queued)")
+23 SET XMQ(+Y)=""
QUIT
+24 ;Remove RCPT
I IF '$DATA(^TMP("XMY",$JOB,Y1))
QUIT
KILL ^TMP("XMY",$JOB,Y1),^TMP("XMY0",$JOB,Y1)
WRITE " Deleted."
+1 QUIT
I2 SET X9=""
SET XMA21A=^XMB("NUM")
IF $LENGTH(X,".")>1!$DATA(XMCHAN)
SET %Z=$PIECE(X,".",$LENGTH(X,"."))
IF %Z="MIL"!(%Z="DE")
SET DIC(0)=DIC(0)_"MXO"
+1 FOR
DO ^DIC
IF $SELECT(Y-XMA21A=0&'$LENGTH(X9)
QUIT
Begin DoDot:1
+2 IF X=^XMB("NETNAME")
Begin DoDot:2
+3 ; XMDOMLK is checked only by ^XMR.
SET Y=-1
SET XMDOMLK=1
+4 SET XMMG="Sub-Domain '"_X9_"' not found."
+5 KILL XMA21A
End DoDot:2
QUIT
+6 SET X9=X9_$SELECT($LENGTH(X9):".",1:"")_$PIECE(X,".")
+7 SET X=$PIECE(X,".",2,999)
+8 IF X=""
KILL XMA21A
IF $EXTRACT(X9)'="#"
SET XMMG="Domain not found."
QUIT
+9 ;I $L(X9,".")>1,X'?.E1".".E,DIC(0)'["X" S DIC(0)=DIC(0)_"X" ; *** WHY?
End DoDot:1
IF '$DATA(XMA21A)
QUIT
+10 IF '$DATA(XMA21A)
IF $EXTRACT(X9)="#"
GOTO I3
+11 QUIT
+12 ;X400 ADDRESSING
I3 SET X="#"
DO ^DIC
IF Y>0
KILL X9
SET X=X1
QUIT
+1 SET XMMG="X.400 DOMAIN not found. MUST HAVE '#' as it's SYNONYM"
QUIT
LOCAL ;Recipient is local
+1 ;Recipient name
+2 SET X=$PIECE(X1,"@")
+3 ;Call Local Name Server Y>0=success
+4 DO W3
SET X=$PIECE(X1,"@")
+5 IF $SELECT(Y>0
QUIT
+6 ;If not successful first time, convert first "," to "." - try again
+7 SET X=$TRANSLATE(X,"._+",", .")
SET XMMG=""
+8 GOTO W3GO
W3 NEW %,XMA21AL
SET %=X1
SET XMA21AL=1
NEW X1
SET X1=%
W3GO NEW XMLOCQ
SET XMLOCQ="QUIT"
DO W3^XMA21
+1 QUIT
NO(X) ;Do not allow message to be sent across network if too long
+1 ;according to field 8.3 of file 4.3
+2 IF $SELECT($DATA(XMCHAN):1,$DATA(XMDF):1,$DATA(^XUSEC("XMMGR",DUZ)):1,1:0)
QUIT 0
+3 NEW %
SET %=$PIECE($GET(^XMB(1,1,"NETWORK-LIMIT")),U)
SET %=$SELECT(%:%,1:2000)
+4 IF $PIECE($GET(^XMB(3.9,X,2,0)),U,4)>%
QUIT %
+5 QUIT 0
IHS ; IHS/MFD screen out addressing to just user@COM, etc.
+1 ;IHS/MFD
NEW XBIHS
FOR XBIHS="COM","GOV","ARPA","NET","ORG","UK","BITNET","UUCP","FI","ZA","CA","MIL"
IF X=XBIHS
SET XMMG="No addressing to "_X_" domain."
SET Y=-1
QUIT
