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

XLFNSLK.m

Go to the documentation of this file. 
  1. XLFNSLK ;ISF/RWF,ISD/HGW - Calling a DNS server for name lookup ;07/11/14  11:18
  1.  ;;8.0;KERNEL;**142,151,425,638**;Jul 10, 1995;Build 16
  1.  ;Per VHA Directive 2004-038, this routine should not be modified.
  1.  ;
  1. TEST ;Test entry
  1.  N XLF,XL1,XL4,XL6,XNAME,Y,I S (XLF,XL4,XL6)=""
  1.  R !,"Enter an IP address to lookup: www.domain.ext//",XNAME:DTIME S:XNAME="" XNAME="www.domain.ext" Q:XNAME["^"
  1.  S XL1=XNAME
  1.  W !!,"Looking up IPv4 address: ",XL1 D NS(.XLF,XL1,"A",.XL4)
  1.  S XL1="XL4" F  S XL1=$Q(@XL1) Q:XL1=""  W !,XL1," = ",@XL1
  1.  S Y="" F  S Y=$O(XLF("B",Y)) Q:Y=""  W !,?5,Y," > ",XLF("B",Y)
  1.  S XL1=XNAME
  1.  W !!,"Looking up IPv6 address: ",XL1 D NS(.XLF,XL1,"AAAA",.XL6)
  1.  S XL1="XL6" F  S XL1=$Q(@XL1) Q:XL1=""  W !,XL1," = ",@XL1
  1.  S Y="" F  S Y=$O(XLF("B",Y)) Q:Y=""  W !,?5,Y," > ",XLF("B",Y)
  1.  W !
  1.  Q
  1.  ;
  1. ADDRESS(N,T) ;Get a IP address from a name
  1.  N XLF,Y,I S XLF="",T=$G(T,"A")
  1.  I $$VERSION^XLFIPV S T=$G(T,"AAAA")      ; change default from "A" to "AAAA" if VistA has IPv6 enabled
  1.  I ^%ZOSF("OS")["OpenM",T="A" D  Q $P(Y,",")
  1.  . X "S Y=$ZU(54,13,N)"              ; $ZU(54,13,N) is gethostbyname(N) IPv4 address nslookup
  1.  D NS(.XLF,N,T)
  1.  S Y="" F I=1:1:XLF("ANCOUNT") S:$D(XLF("AN"_I_"DATA")) Y=Y_XLF("AN"_I_"DATA")_","
  1.  Q $E(Y,1,$L(Y)-1)
  1.  ;
  1. MAIL(RET,N) ;Get the MX address for a domain
  1.  ;RET is the return array
  1.  N XLF,Y,I,T S XLF="",T="MX"
  1.  D NS(.XLF,N,T)
  1.  S RET=0,I=0 F  S I=$O(XLF("P",I)) Q:I'>0  D
  1.  . S N=XLF("P",I),RET(I)=N_"^"_$G(XLF("B",N)),RET=RET+1
  1.  Q
  1.  ;
  1. NS(XL,NAME,QTYPE,XLFLOG) ;NAME LOOKUP
  1.  ;XL is the return array, NAME is the name to lookup,
  1.  ;QTYPE is type of lookup, XLFLOG is a debug array returned.
  1.  N RI,DNS,CNT,POP N:'$D(XLFLOG) XLFLOG S XL("ANCOUNT")=0,CNT=1
  1.  D SAVEDEV
  1. NS2 S DNS=$$GETDNS(CNT) I DNS="" G EXIT
  1.  D LOG("Call server: "_DNS)
  1.  D CALL^%ZISTCP(DNS,53) I POP S CNT=CNT+1 G NS2
  1.  D LOG("Got connection, Send message")
  1.  D BUILD(NAME,$G(QTYPE,"A")),LOG("Wait for reply")  ; Uses "A" type for IPv4 if QTYPE is not defined
  1.  ;Close part of READ
  1.  D READ,DECODE
  1.  D RESDEV,LOG("Returned question: "_$G(XL("QD1NAME")))
  1.  Q
  1. EXIT D RESDEV
  1.  Q
  1.  ;
  1. BUILD(Y,T) ;BUILD A QUERY
  1.  ; ID,PARAM,#of?, #ofA, #of Auth, #of add,
  1.  N X,%,MSG,I
  1.  S X=" M"_$C(1,0)_$C(0,1)_$C(0,0)_$C(0,0)_$C(0,0) ;Header
  1.  I $E(Y,$L(Y))'="." S:$E(Y,$L(Y))'="." Y=Y_"."                           ;future fix: implies IPv4 address for DNS server
  1.  F I=1:1:$L(Y,".") S %=$P(Y,".",I) S:$L(%) X=X_$C($L(%))_% ;Address      ;future fix: implies IPv4 address for DNS server
  1.  S X=X_$C(0) ;End of address                                             ;future fix: implies IPv4 address for DNS server
  1.  ;Type A=1, NS=2, CNAME=5, MX=15, AAAA=28                                ;p638 Added "AAAA" for IPv6
  1.  S MSG=X_$C(0,$$TYPECODE(T))_$C(0,1) ;type and class
  1.  D LOG("msg: "_MSG)
  1.  U IO S %=$L(MSG) W $C(%\256,%#256)_MSG,!
  1.  Q
  1. READ ;
  1.  N L1,L2,X,$ET S $ET="G RDERR" K RI S RI=0
  1.  U IO R L1#2:20 I '$T D LOG("Time-out") G RDERR
  1.  S RI=$A(L1,1)*256+$A(L1,2) ;get msg length
  1.  F I=1:1:6 R L2#2:20 Q:'$T  S XL($P("ID^CODE^QDCOUNT^ANCOUNT^NSCOUNT^ARCOUNT","^",I))=$S(I>2:$$WBN(L2),I=2:$$BIN16(L2),1:L2)
  1.  I '$T D LOG("Time-out") G RDERR
  1.  D LOG("Return msg length: "_RI)
  1.  F I=13:1:RI U IO R *X:20 Q:'$T  S RI(I)=X ;or use X#1 and $A(X)
  1. RDERR ;End of read
  1.  D CLOSE^%ZISTCP
  1.  Q
  1. DECODE ;
  1.  N I,IX,X,Y,Z,NN,NN2 Q:RI'>7
  1.  I $G(XL("ID"))'=" M" S XL("ERR")="Bad Response" D LOG(XL("ERR")) Q
  1.  ;Decode the header
  1.  S Z=XL("CODE"),XL("QR")=$E(Z,1),XL("Opcode")=$E(Z,2,5),XL("AA")=$E(Z,6),XL("TC")=$E(Z,7),XL("RD")=$E(Z,8),XL("RA")=$E(Z,9),XL("RCODE")=$E(Z,13,16)
  1.  ;The Question section
  1.  S IX=13
  1.  F NN2=1:1:XL("QDCOUNT") D QD("QD"_NN2)
  1.  F NN="AN","NS","AR" I $G(XL(NN_"COUNT")) F NN2=1:1:XL(NN_"COUNT") D RR(NN_NN2)
  1.  Q
  1.  ;
  1. QD(NSP) ;Decode the Question section
  1.  N Y
  1.  S Y="",IX=IX+$$NAME(IX,.Y,1),XL(NSP_"NAME")=Y
  1.  S XL(NSP_"TYPE")=$$BN(RI(IX),RI(IX+1)),IX=IX+2
  1.  S XL(NSP_"CLASS")=$$BN(RI(IX),RI(IX+1)),IX=IX+2
  1.  Q
  1. RR(NSP) ;
  1.  N Y,NA
  1.  S Y="",IX=IX+$$NAME(IX,.Y,1),XL(NSP_"NAME")=Y,NA=Y
  1.  S XL(NSP_"TYPE")=$$BN(RI(IX),RI(IX+1)),IX=IX+2
  1.  S XL(NSP_"CLASS")=$$BN(RI(IX),RI(IX+1)),IX=IX+2
  1.  S Y=RI(IX)*256+RI(IX+1),Y=Y*256+RI(IX+2),Y=Y*256+RI(IX+3)
  1.  S XL(NSP_"TTL")=Y,IX=IX+4
  1.  S (X,XL(NSP_"LENGTH"))=$$BN(RI(IX),RI(IX+1)),IX=IX+2 Q:X=0
  1.  I XL(NSP_"TYPE")=1 D                                                                       ; IPv4 address
  1.  . S XL(NSP_"DATA")=RI(IX)_"."_RI(IX+1)_"."_RI(IX+2)_"."_RI(IX+3),XL("B",NA)=XL(NSP_"DATA")
  1.  I XL(NSP_"TYPE")=28 D                                                                      ; IPv6 address
  1.  . S XL(NSP_"DATA")=$$H1(RI(IX))_$$H1(RI(IX+1))_":"_$$H1(RI(IX+2))_$$H1(RI(IX+3))_":"
  1.  . S XL(NSP_"DATA")=XL(NSP_"DATA")_$$H1(RI(IX+4))_$$H1(RI(IX+5))_":"_$$H1(RI(IX+6))_$$H1(RI(IX+7))_":"
  1.  . S XL(NSP_"DATA")=XL(NSP_"DATA")_$$H1(RI(IX+8))_$$H1(RI(IX+9))_":"_$$H1(RI(IX+10))_$$H1(RI(IX+11))_":"
  1.  . S XL(NSP_"DATA")=XL(NSP_"DATA")_$$H1(RI(IX+12))_$$H1(RI(IX+13))_":"_$$H1(RI(IX+14))_$$H1(RI(IX+15))
  1.  . S XL("B",NA)=XL(NSP_"DATA")
  1.  I XL(NSP_"TYPE")=15 D MX(IX)                                                               ; MX entry
  1.  S IX=IX+XL(NSP_"LENGTH")
  1.  Q
  1. NAME(I,NM,F) ;Decode a NAME section
  1.  N P,T,Y,X S NM=$G(NM) S:F T=0
  1.  F  S X=RI(I) S:(X=0)&F T=T+1 Q:X=0  D  Q:X=0  ;Use X as flag to escape recursion.
  1.  . I (X\64)=3 S X=$$NAME((X#64)*256+RI(I+1)+1,.NM,0),X=0 S:F T=T+2 Q
  1.  . S NM=NM_$$PART(I+1,X),I=I+X+1 S:F T=T+X+1
  1.  Q $G(T)
  1.  ;
  1. MX(IX) ;Hide IX changes
  1.  N Y S Y=$$BN(RI(IX),RI(IX+1))
  1.  F  Q:'$D(XL("P",Y))  S Y=Y+1
  1.  S XL(NSP_"PREF")=Y,IX=IX+2
  1.  S Y="",IX=IX+$$NAME(IX,.Y,1),XL(NSP_"NAME")=Y,XL("P",XL(NSP_"PREF"))=Y
  1.  Q
  1.  ;
  1. BN(Z1,Z2) ;Convert two binary char 16 bit number into ASCII number
  1.  Q Z1*256+Z2
  1.  ;
  1. WBN(Z1) ;Convert two byte string to a ASCII number
  1.  Q $A(Z1,1)*256+$A(Z1,2)
  1.  ;
  1. H2(Z2) ;Convert 2 byte string to HEX
  1.  N B S B=$A(Z2,1)*256+$A(Z2,2)
  1.  Q $$H(B)
  1.  ;
  1. H1(Z1) ;Convert decimal number <= 256 to two digit HEX number
  1.  N Y S Y=$$CNV^XLFUTL(Z1,16)
  1.  Q $$RJ^XLFSTR(Y,2,"0")
  1.  ;
  1. H(Z1) Q $$BASE^XLFUTL(Z1,10,16)
  1.  ;
  1. BIN16(S) ;Convert two byte string to 16 bit binary
  1.  N K,Y S S=$A(S,1)*256+$A(S,2),Y=""
  1.  F K=0:1:15 S Y=(S\(2**K)#2)_Y
  1.  Q Y
  1.  ;
  1. PART(S,L) ;
  1.  N R,A S R="" F A=S:1:S+L-1 S R=R_$C(RI(A))
  1.  Q R_"."
  1.  ;
  1. TYPECODE(T) ;
  1.  ;1=A:IPv4 address,2=NS:nameserver,5=CNAME,15=MX:mail exchange,28=AAAA:IPv6 address  ;p638 Added "AAAA" for IPv6
  1.  I +T Q $S(T=1:"A",T=2:"NS",T=5:"CNAME",T=15:"MX",T=28:"AAAA",1:"ZZ")                ;p638 Added "AAAA" for IPv6
  1.  Q $S(T="A":1,T="NS":2,T="CNAME":5,T="MX":15,T="AAAA":28,1:1)                        ;p638 Added "AAAA" for IPv6
  1.  ;
  1. CLASS(T) ;
  1.  Q $S(T=1:"IN",1:"ZZ")
  1.  ;
  1. GETDNS(I) ;Get the address of our DNS
  1.  N L S L=$G(^XTV(8989.3,1,"DNS"))
  1.  Q $P(L,",",I)
  1.  ;
  1. SHOW ;LIST RI AND XL
  1.  S O1=RI\3+1,O2=O1*2
  1.  F I=1:1:O1 D SW(0,"RI("_I_")=",$G(RI(I))),SW(30,"RI("_(I+O1)_")=",$G(RI(I+O1))),SW(60,"RI("_(I+O2)_")=",$G(RI(I+O2))) W !
  1.  Q
  1. SW(T,H,V) ;
  1.  W ?T,$J(H,8),V
  1.  Q
  1. SAVEDEV ;Save calling device
  1.  D:'$D(IO(0)) HOME^%ZIS D SAVDEV^%ZISUTL("XLFNSLK")
  1.  Q
  1. RESDEV ;Restore calling device
  1.  D USE^%ZISUTL("XLFNSLK"),RMDEV^%ZISUTL("XLFNSLK")
  1.  K IO("CLOSE")
  1.  Q
  1. LOG(M) ;Log Debug messages
  1.  S XLFLOG=$G(XLFLOG)+1,XLFLOG(XLFLOG)=M
  1.  Q
  1.  ;
  1. POST ;Stuff a DNS address during install POST init.
  1.  N DIC,DR,DIQ,XLF,DIE
  1.  S XLF=$P($$PARAM^HLCS2,U,3)
  1.  I XLF="T" D BMES^XPDUTL("Test Account DNS address not installed.") Q
  1.  S DIC=8989.3,DR=51,DA=1,DIQ="XLF(" D EN^DIQ1 I $L(XLF(8989.3,1,51)) Q
  1.  S DR="51///127.0.0.1",DIE="^XTV(8989.3,",DA=1 D ^DIE
  1.  D BMES^XPDUTL("DNS address installed.")
  1.  Q