Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XMXADDRD

XMXADDRD.m

Go to the documentation of this file.
  1. XMXADDRD ;ISC-SF/GMB-Lookup Domain Name ;04/24/2002 10:36
  1. ;;8.0;MailMan;;Jun 28, 2002
  1. ; Replaces PSP^XMA210,^XMA21A,^XMA21B (ISC-WASH/CAP)
  1. DNS(XMDUZ,XMDOMAIN,XMVIA,XMVIAN) ;
  1. ; XMDOMAIN - (in/out) Domain name. May be mixed case. Must already be
  1. ; in xxx.xxx.xxx format.
  1. ; XMVIA - (out) IEN of (relay) domain (in ^DIC(4.2))
  1. ; XMVIAN - (out) Name of (relay) domain
  1. N XMVIAREC,XMNETNAM
  1. S XMNETNAM=^XMB("NETNAME")
  1. S XMDOMAIN=$$UP^XLFSTR(XMDOMAIN)
  1. I XMDOMAIN=XMNETNAM D Q
  1. . S XMVIA=^XMB("NUM")
  1. . S XMVIAN=XMNETNAM
  1. D FINDDOMN
  1. Q:$D(XMERROR)
  1. I XMVIAN="DOMAIN.EXT",$$FORUM D Q
  1. . D SETERR^XMXADDR4($G(XMIA),"!",39100,XMDOMAIN) ;Domain not found: |1|
  1. I $G(XMIA) D
  1. . W:XMDOMAIN'=XMVIAN $$EZBLD^DIALOG(39101,XMVIAN) ;via |1|
  1. . I XMVIAN'=XMNETNAM,$P(XMVIAREC,U,2)'["S" W $$EZBLD^DIALOG(39102) ; queued
  1. Q
  1. FORUM() ; Is this FORUM or GATEWAY?
  1. Q $S($G(XMNETNAM,^XMB("NETNAME"))'["FORUM.":0,1:1)
  1. FINDDOMN ; Look up domain
  1. N XMSUBDOM,XMFLAGS,DIC,X,Y,XMDCIRCL
  1. S XMSUBDOM="",X=XMDOMAIN
  1. ;S XMFLAGS="ZMF"_$S('$G(XMIA):"O",$G(XMINSTR("EXACT")):"OE",$D(XMGCIRCL):"OE",1:"E")
  1. S XMFLAGS="ZMF"_$S($G(XMINSTR("EXACT")):"X",'$G(XMIA):"O",$D(XMGCIRCL):"O",1:"")_$S($G(XMIA):"E",1:"")
  1. S DIC="^DIC(4.2,",DIC(0)=XMFLAGS
  1. F S D="B^C" D MIX^DIC1 Q:Y>0!(X'[".")!$D(DUOUT)!$D(DTOUT) D Q:X=XMNETNAM
  1. . S XMSUBDOM=XMSUBDOM_$P(X,".")_"."
  1. . S X=$P(X,".",2,999)
  1. I Y'>0,X'[".",'$G(XMIA),$L(X)<4 S DIC(0)="ZFX",D="C" D IX^DIC ; Look for COM,MIL,NET,etc. as synonym for one of the domains.
  1. I Y>0 D Q ; Domain successfully found
  1. . I XMSUBDOM'="" D Q:$D(XMERROR)
  1. . . D CHKDOM($E(XMSUBDOM,1,$L(XMSUBDOM)-1)) Q:$D(XMERROR)
  1. . . Q:Y(0,0)'=XMNETNAM
  1. . . D SETERR^XMXADDR4($G(XMIA),"!",39103,$E(XMSUBDOM,1,$L(XMSUBDOM)-1),X) ; Sub-domain '|1|' not found for domain '|2|'
  1. . I XMSUBDOM="",X'[".",$L(X)<4,$$FIND1^DIC(4.2996,"","QX",X) D NEEDSUB(X) Q
  1. . S XMDOMAIN=$S(XMSUBDOM="":Y(0,0),1:XMSUBDOM_X) ; MailMan's klugey way
  1. . ;S XMDOMAIN=XMSUBDOM_X ; Proper way? Nope.
  1. . S XMVIA=+Y
  1. . S XMVIAREC=Y(0)
  1. . D VIA(.XMVIA,.XMVIAREC,.XMVIAN,.XMDCIRCL)
  1. I '$G(XMIA),X'=XMNETNAM D Q:$D(XMERROR)
  1. . N Y,X
  1. . S X=XMDOMAIN
  1. . F S Y=$$FIND1^DIC(4.2,"","MOQ",X,"B^C") Q:Y>0!$D(DIERR)!(X'[".") D
  1. . . S X=$P(X,".",2,999)
  1. . Q:Y!'$D(DIERR) ; (Y should never be >0, because we didn't find it before.)
  1. . I X'[".",$$FIND1^DIC(4.2996,"","QX",X) Q
  1. . D SETERR^XMXADDR4(0,"",39106,X) ;Domain ambiguous: |1|
  1. I $D(DTOUT)!$D(DUOUT) D Q
  1. . ;up-arrow out. / time out.
  1. . D SETERR^XMXADDR4(1,"!",$S($D(DUOUT):37000,1:37001))
  1. I X'["." D Q ; Domain not found, look in internet suffix file
  1. . D LOOKSFX Q:$D(XMERROR)
  1. . I X=XMDOMAIN D NEEDSUB(X) Q
  1. . D CHKDOM($E(XMSUBDOM,1,$L(XMSUBDOM)-1))
  1. I X=XMNETNAM D Q ;Sub-domain '|1|' not found for domain '|2|'
  1. . D SETERR^XMXADDR4($G(XMIA),"!",39103,$E(XMSUBDOM,1,$L(XMSUBDOM)-1),X)
  1. Q
  1. NEEDSUB(X) ;
  1. D SETERR^XMXADDR4(0,"",39104,X) ;Valid domain, but need subdomain: |1|
  1. Q:'$G(XMIA)
  1. ;Domain |1| is a valid Internet domain,
  1. ;but you must specify at least one sub-domain.
  1. N XMTEXT
  1. D BLD^DIALOG(39105,X,"","XMTEXT","F")
  1. D MSG^DIALOG("WE","","","","XMTEXT")
  1. Q
  1. VIA(XMVIA,XMVIAREC,XMVIAN,XMDCIRCL) ;
  1. S XMVIAN=$P(XMVIAREC,U,1)
  1. Q:XMVIAN=XMNETNAM
  1. D CHKPRMIT(XMDUZ,XMVIAREC) Q:$D(XMERROR)
  1. I $D(XMDCIRCL(XMVIA)) D Q
  1. . I $G(XMIA) D EN^DDIOL($$EZBLD^DIALOG(39088)) ;Error:
  1. . ;Circular relay domain: |1|
  1. . D SETERR^XMXADDR4($G(XMIA),"",39107,XMVIAN)
  1. I $P(XMVIAREC,U,3) D Q ; If there's a relay domain, follow it.
  1. . S XMDCIRCL(XMVIA)=""
  1. . S XMVIA=$P(XMVIAREC,U,3),XMVIAREC=$G(^DIC(4.2,XMVIA,0))
  1. . D VIA(.XMVIA,.XMVIAREC,.XMVIAN,.XMDCIRCL)
  1. Q:$P(XMVIAREC,U,2)'["S"
  1. Q:$O(^DIC(4.2,XMVIA,1,0)) ; Domain has script(s).
  1. Q:$L(XMVIAN)+1=$F(XMVIAN,XMNETNAM) ; Subdomain of this domain.
  1. N Y
  1. I $L(XMVIAN,".")>3 D I Y,$P(^DIC(4.2,+Y,0),U,1)=XMNETNAM Q ; Subdomain of this domain.
  1. . N X
  1. . S X=$P(XMVIAN,".",2,999)
  1. . F S Y=$$FIND1^DIC(4.2,"","QX",X,"C") Q:Y!($L(X,".")<3) D
  1. . . S X=$P(X,".",2,999)
  1. ; No script, so send to parent domain, if there is one,
  1. ; and if the parent isn't the same as this domain.
  1. Q:'$G(^XMB("PARENT"))
  1. Q:'$G(^XMB("NUM"))
  1. Q:^XMB("PARENT")=^XMB("NUM")
  1. Q:'$D(^DIC(4.2,^XMB("PARENT"),0))
  1. S XMVIA=^XMB("PARENT")
  1. S XMVIAREC=^DIC(4.2,XMVIA,0)
  1. S XMVIAN=$P(XMVIAREC,U,1)
  1. Q
  1. CHKDOM(XMDOM,XMMAXDOM,XMMAXDOT) ;
  1. N I,XMSUBDOM
  1. I $TR(XMDOM,".-","")'?.AN D Q
  1. . ;Domain may not contain punctuation other than '.' or '-'.
  1. . D SETERR^XMXADDR4($G(XMIA),"!",39108)
  1. I '$D(XMMAXDOM) S XMMAXDOM=255
  1. I $L(XMDOM)>XMMAXDOM D Q
  1. . ;Domain must be from 1 to |1| characters.
  1. . D SETERR^XMXADDR4($G(XMIA),"!",39109,XMMAXDOM)
  1. I '$D(XMMAXDOT) S XMMAXDOT=63
  1. F I=1:1:$L(XMDOM,".") D Q:$D(XMERROR)
  1. . S XMSUBDOM=$P(XMDOM,".",I)
  1. . I XMSUBDOM?1AN.E,$L(XMSUBDOM)'>XMMAXDOT Q
  1. . ; 39110 - Domain dot pieces must be from 1 to |1| characters.
  1. . ; 39111 - Domain dot pieces must begin with a letter or number.
  1. . D SETERR^XMXADDR4($G(XMIA),"!",$S($L(XMSUBDOM,I)>XMMAXDOT:39110,1:39111),XMMAXDOT)
  1. . Q:'$G(XMIA)
  1. . D EN^DDIOL($$EZBLD^DIALOG(39112,XMSUBDOM)) ;|1| is not valid.
  1. Q
  1. LOOKSFX ; Look for top level domain in internet suffix file
  1. ; Instead of looking in the file, we could call the COTS DNS, if it exists.
  1. N DIC,Y
  1. I $G(XMIA) D
  1. . D EN^DDIOL($$EZBLD^DIALOG(39113)) ;Looking in Internet Suffix file...
  1. . S DIC(0)=$TR(XMFLAGS,"O")_"X"
  1. E S DIC(0)="X"
  1. S DIC="^DIC(4.2996,"
  1. S:$G(XMIA) DIC("W")="W "" "",$P(^(0),U,2)" ; high-level domain purpose/country
  1. D ^DIC
  1. I Y>0 D Q:XMVIA
  1. . S XMVIA=$G(^XMB("PARENT"))
  1. . I 'XMVIA S XMVIA=$$FIND1^DIC(4.2,"","MQX",$S($$FORUM:"GK.DOMAIN.EXT",1:"DOMAIN.EXT"),"B^C") Q:'XMVIA
  1. . S XMVIAREC=^DIC(4.2,XMVIA,0)
  1. . S XMVIAN=$P(XMVIAREC,U)
  1. D SETERR^XMXADDR4($G(XMIA),"!",39100,X) ;Domain not found: |1|
  1. Q
  1. CHKPRMIT(XMDUZ,XMVIAREC) ;
  1. I $G(XMINSTR("ADDR FLAGS"))["R",'$D(XMRESTR("NET RECEIVE")) Q
  1. I $P(XMVIAREC,U,2)["C",$P(XMVIAREC,U,2)'["S" D Q ;Domain closed: |1|
  1. . D SETERR^XMXADDR4($G(XMIA),"!",39114,$P(XMVIAREC,U,1))
  1. Q:$G(XMINSTR("ADDR FLAGS"))["R"
  1. I $P(XMVIAREC,U,11)'="",'$D(^XUSEC($P(XMVIAREC,U,11),XMDUZ)) D Q
  1. . ;You don't hold key to domain '|1|'.
  1. . D SETERR^XMXADDR4($G(XMIA),"!",39115,$P(XMVIAREC,U,1))
  1. ; Maybe the following belongs in XMFWD^XMVVITAE:
  1. ;I $P(XMVIAREC,U,2)["N" D Q
  1. ;. D SETERR^XMXADDR4($G(XMIA),"!",XXXXX,$P(XMVIAREC,U,1)) ; No forwarding to domain '|1|'.
  1. Q
  1. CHKNAME ; Input transform for .01 field of DOMAIN file 4.2
  1. N XMIA,XMERROR,I
  1. S XMIA=0
  1. S X=$$UP^XLFSTR(X)
  1. D CHKDOM(X,64,20)
  1. I $D(XMERROR) D Q
  1. . D WRIERR^XMXADDR4("!,$C(7)")
  1. . K X
  1. Q:$D(DIFROM)
  1. F I=1:1:$L(X,".")-1 D Q:'$D(X)
  1. . Q:'$D(^DIC(4.2996,"B",$P(X,".",I),0))
  1. . D EN^DDIOL($$EZBLD^DIALOG(39116),"","!,$C(7)")
  1. . K X ;Domain dot pieces must not match Internet reserved domain names.
  1. Q