XLFNSLK ;ISF/RWF,ISD/HGW - Calling a DNS server for name lookup ;12/08/15 12:44
;;8.0;KERNEL;**142,151,425,638,659**;Jul 10, 1995;Build 22
;Per VA Directive 6402, this routine should not be modified.
;
Q
TEST ;Test entry
N XNAME
R !,"Enter an IP address to lookup: www.domain.ext//",XNAME:DTIME S:XNAME="" XNAME="www.domain.ext" Q:XNAME["^"
W !!,"Looking up IPv4 address: ",XNAME
W !,?5,XNAME,". > ",$$ADDRESS(XNAME,"A")
W !!,"Looking up IPv6 address: ",XNAME
W !,?5,XNAME,". > ",$$ADDRESS(XNAME,"AAAA")
W !
Q
;
HOST(IP) ;Get a host name from an IP address
;ZEXCEPT: AddrToHostName,INetInfo,TextAddrToBinary ;Kernel exemption for Cache Objects
N X,Y
I $$VERSION^%ZOSV(1)["Cache" D Q Y
. S X=$SYSTEM.INetInfo.TextAddrToBinary(IP)
. S Y=$SYSTEM.INetInfo.AddrToHostName(X)
;Enter code for non-Cache systems here:
Q ""
;
ADDRESS(N,T) ;Get a IP address from a name
;ZEXCEPT: HostNameToAddr,INetInfo ;Kernel exemption for Cache Objects
N X,XLF,Y,I S XLF="",Y=0
I $$VERSION^XLFIPV S T=$G(T,"AAAA")
E S T=$G(T,"A") ; change default to "A" if VistA has IPv6 disabled
I ($$VERSION^%ZOSV(1)["Cache")&((T="A")!(T="AAAA")) D Q Y
. I T="AAAA" D
. . S X=$SYSTEM.INetInfo.HostNameToAddr(N,2,0) ;Get IPv6 address
. . S Y=$$FORCEIP6^XLFIPV(X) ;Format IPv6 address
. I ($P(Y,":")="0000")!(T="A") S Y=$SYSTEM.INetInfo.HostNameToAddr(N,1,0) ;Get IPv4 address
;Non-cache systems and lookups other than "A" or "AAAA"
D NS(.XLF,N,T)
S Y="" F I=1:1:XLF("ANCOUNT") S:$D(XLF("AN"_I_"DATA")) Y=Y_XLF("AN"_I_"DATA")_","
Q $E(Y,1,$L(Y)-1)
;
MAIL(RET,N) ;Get the MX address for a domain
;RET is the return array
N XLF,Y,I,T S XLF="",T="MX"
D NS(.XLF,N,T)
S RET=0,I=0 F S I=$O(XLF("P",I)) Q:I'>0 D
. S N=XLF("P",I),RET(I)=N_"^"_$G(XLF("B",N)),RET=RET+1
Q
;
NS(XL,NAME,QTYPE,XLFLOG) ;NAME LOOKUP
;XL is the return array, NAME is the name to lookup,
;QTYPE is type of lookup, XLFLOG is a debug array returned.
N RI,DNS,CNT,POP N:'$D(XLFLOG) XLFLOG S XL("ANCOUNT")=0,CNT=1
D SAVEDEV
NS2 ;
S DNS=$$GETDNS(CNT) I DNS="" G EXIT
D LOG("Call server: "_DNS)
D CALL^%ZISTCP(DNS,53) I POP S CNT=CNT+1 G NS2
D LOG("Got connection, Send message")
D BUILD(NAME,$G(QTYPE,"AAAA")),LOG("Wait for reply") ; Uses "AAAA" type for IPv6 if QTYPE is not defined
;Close part of READ
D READ,DECODE
D RESDEV,LOG("Returned question: "_$G(XL("QD1NAME")))
Q
EXIT D RESDEV
Q
;
BUILD(Y,T) ;BUILD A QUERY
; ID,PARAM,#of?, #ofA, #of Auth, #of add,
N X,%,MSG,I
S X=" M"_$C(1,0)_$C(0,1)_$C(0,0)_$C(0,0)_$C(0,0) ;Header
I $E(Y,$L(Y))'="." S:$E(Y,$L(Y))'="." Y=Y_"."
F I=1:1:$L(Y,".") S %=$P(Y,".",I) S:$L(%) X=X_$C($L(%))_% ;FQDN Address
S X=X_$C(0) ;End of FQDN address
;Type A=1, NS=2, CNAME=5, MX=15, AAAA=28
S MSG=X_$C(0,$$TYPECODE(T))_$C(0,1) ;type and class
D LOG("msg: "_MSG)
U IO S %=$L(MSG) W $C(%\256,%#256)_MSG,!
Q
READ ;
;ZEXCEPT: I,RI,XL ;Global variables within this routine
N L1,L2,X,$ET S $ET="G RDERR" K RI S RI=0
U IO R L1#2:20 I '$T D LOG("Time-out") G RDERR
S RI=$A(L1,1)*256+$A(L1,2) ;get msg length
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)
I '$T D LOG("Time-out") G RDERR
D LOG("Return msg length: "_RI)
F I=13:1:RI U IO R *X:20 Q:'$T S RI(I)=X ;or use X#1 and $A(X)
RDERR ;End of read
D CLOSE^%ZISTCP
Q
DECODE ;
;ZEXCEPT: XL ;Global variable within this routine
N I,IX,X,Y,Z,NN,NN2 Q:RI'>7
I $G(XL("ID"))'=" M" S XL("ERR")="Bad Response" D LOG(XL("ERR")) Q
;Decode the header
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)
;The Question section
S IX=13
F NN2=1:1:XL("QDCOUNT") D QD("QD"_NN2)
F NN="AN","NS","AR" I $G(XL(NN_"COUNT")) F NN2=1:1:XL(NN_"COUNT") D RR(NN_NN2)
Q
;
QD(NSP) ;Decode the Question section
;ZEXCEPT: IX,RI,XL ;Global variables within this routine
N Y
S Y="",IX=IX+$$NAME(IX,.Y,1),XL(NSP_"NAME")=Y
S XL(NSP_"TYPE")=$$BN(RI(IX),RI(IX+1)),IX=IX+2
S XL(NSP_"CLASS")=$$BN(RI(IX),RI(IX+1)),IX=IX+2
Q
RR(NSP) ;
;ZEXCEPT: IX,RI,X,XL ;Global variables within this routine
N Y,NA
S Y="",IX=IX+$$NAME(IX,.Y,1),XL(NSP_"NAME")=Y,NA=Y
S XL(NSP_"TYPE")=$$BN(RI(IX),RI(IX+1)),IX=IX+2
S XL(NSP_"CLASS")=$$BN(RI(IX),RI(IX+1)),IX=IX+2
S Y=RI(IX)*256+RI(IX+1),Y=Y*256+RI(IX+2),Y=Y*256+RI(IX+3)
S XL(NSP_"TTL")=Y,IX=IX+4
S (X,XL(NSP_"LENGTH"))=$$BN(RI(IX),RI(IX+1)),IX=IX+2 Q:X=0
I XL(NSP_"TYPE")=1 D ; IPv4 address
. S XL(NSP_"DATA")=RI(IX)_"."_RI(IX+1)_"."_RI(IX+2)_"."_RI(IX+3),XL("B",NA)=XL(NSP_"DATA")
I XL(NSP_"TYPE")=28 D ; IPv6 address
. S XL(NSP_"DATA")=$$H1(RI(IX))_$$H1(RI(IX+1))_":"_$$H1(RI(IX+2))_$$H1(RI(IX+3))_":"
. S XL(NSP_"DATA")=XL(NSP_"DATA")_$$H1(RI(IX+4))_$$H1(RI(IX+5))_":"_$$H1(RI(IX+6))_$$H1(RI(IX+7))_":"
. S XL(NSP_"DATA")=XL(NSP_"DATA")_$$H1(RI(IX+8))_$$H1(RI(IX+9))_":"_$$H1(RI(IX+10))_$$H1(RI(IX+11))_":"
. S XL(NSP_"DATA")=XL(NSP_"DATA")_$$H1(RI(IX+12))_$$H1(RI(IX+13))_":"_$$H1(RI(IX+14))_$$H1(RI(IX+15))
. S XL("B",NA)=XL(NSP_"DATA")
I XL(NSP_"TYPE")=15 D MX(IX) ; MX entry
S IX=IX+XL(NSP_"LENGTH")
Q
NAME(I,NM,F) ;Decode a NAME section
;ZEXCEPT: RI ;Global variable within this routine
N P,T,Y,X S NM=$G(NM) S:F T=0
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.
. I (X\64)=3 S X=$$NAME((X#64)*256+RI(I+1)+1,.NM,0),X=0 S:F T=T+2 Q
. S NM=NM_$$PART(I+1,X),I=I+X+1 S:F T=T+X+1
Q $G(T)
;
MX(IX) ;Hide IX changes
;ZEXCEPT: NSP,RI,XL ;Global variables within this routine
N Y S Y=$$BN(RI(IX),RI(IX+1))
F Q:'$D(XL("P",Y)) S Y=Y+1
S XL(NSP_"PREF")=Y,IX=IX+2
S Y="",IX=IX+$$NAME(IX,.Y,1),XL(NSP_"NAME")=Y,XL("P",XL(NSP_"PREF"))=Y
Q
;
BN(Z1,Z2) ;Convert two binary char 16 bit number into ASCII number
Q Z1*256+Z2
;
WBN(Z1) ;Convert two byte string to a ASCII number
Q $A(Z1,1)*256+$A(Z1,2)
;
H2(Z2) ;Convert 2 byte string to HEX
N B S B=$A(Z2,1)*256+$A(Z2,2)
Q $$H(B)
;
H1(Z1) ;Convert decimal number <= 256 to two digit HEX number
N Y S Y=$$CNV^XLFUTL(Z1,16)
Q $$RJ^XLFSTR(Y,2,"0")
;
H(Z1) Q $$BASE^XLFUTL(Z1,10,16)
;
BIN16(S) ;Convert two byte string to 16 bit binary
N K,Y S S=$A(S,1)*256+$A(S,2),Y=""
F K=0:1:15 S Y=(S\(2**K)#2)_Y
Q Y
;
PART(S,L) ;
;ZEXCEPT: RI ;Global variable within this routine
N R,A S R="" F A=S:1:S+L-1 S R=R_$C(RI(A))
Q R_"."
;
TYPECODE(T) ;
;1=A:IPv4 address,2=NS:nameserver,5=CNAME,15=MX:mail exchange,28=AAAA:IPv6 address
I +T Q $S(T=1:"A",T=2:"NS",T=5:"CNAME",T=15:"MX",T=28:"AAAA",1:"ZZ")
Q $S(T="A":1,T="NS":2,T="CNAME":5,T="MX":15,T="AAAA":28,1:1)
;
CLASS(T) ;
Q $S(T=1:"IN",1:"ZZ")
;
GETDNS(I) ;Get the address of our DNS
N L S L=$G(^XTV(8989.3,1,"DNS"))
Q $P(L,",",I)
;
SW(T,H,V) ;
W ?T,$J(H,8),V
Q
SAVEDEV ;Save calling device
D:'$D(IO(0)) HOME^%ZIS D SAVDEV^%ZISUTL("XLFNSLK")
Q
RESDEV ;Restore calling device
D USE^%ZISUTL("XLFNSLK"),RMDEV^%ZISUTL("XLFNSLK")
K IO("CLOSE")
Q
LOG(M,XLFLOG) ;Log Debug messages
;ZEXCEPT: XLFLOG ;Global variable within this routine
S XLFLOG=$G(XLFLOG)+1,XLFLOG(XLFLOG)=M
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXLFNSLK 7421 printed Oct 16, 2024@18:03:53 Page 2
XLFNSLK ;ISF/RWF,ISD/HGW - Calling a DNS server for name lookup ;12/08/15 12:44
+1 ;;8.0;KERNEL;**142,151,425,638,659**;Jul 10, 1995;Build 22
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
TEST ;Test entry
+1 NEW XNAME
+2 READ !,"Enter an IP address to lookup: www.domain.ext//",XNAME:DTIME
if XNAME=""
SET XNAME="www.domain.ext"
if XNAME["^"
QUIT
+3 WRITE !!,"Looking up IPv4 address: ",XNAME
+4 WRITE !,?5,XNAME,". > ",$$ADDRESS(XNAME,"A")
+5 WRITE !!,"Looking up IPv6 address: ",XNAME
+6 WRITE !,?5,XNAME,". > ",$$ADDRESS(XNAME,"AAAA")
+7 WRITE !
+8 QUIT
+9 ;
HOST(IP) ;Get a host name from an IP address
+1 ;ZEXCEPT: AddrToHostName,INetInfo,TextAddrToBinary ;Kernel exemption for Cache Objects
+2 NEW X,Y
+3 IF $$VERSION^%ZOSV(1)["Cache"
Begin DoDot:1
+4 SET X=$SYSTEM.INetInfo.TextAddrToBinary(IP)
+5 SET Y=$SYSTEM.INetInfo.AddrToHostName(X)
End DoDot:1
QUIT Y
+6 ;Enter code for non-Cache systems here:
+7 QUIT ""
+8 ;
ADDRESS(N,T) ;Get a IP address from a name
+1 ;ZEXCEPT: HostNameToAddr,INetInfo ;Kernel exemption for Cache Objects
+2 NEW X,XLF,Y,I
SET XLF=""
SET Y=0
+3 IF $$VERSION^XLFIPV
SET T=$GET(T,"AAAA")
+4 ; change default to "A" if VistA has IPv6 disabled
IF '$TEST
SET T=$GET(T,"A")
+5 IF ($$VERSION^%ZOSV(1)["Cache")&((T="A")!(T="AAAA"))
Begin DoDot:1
+6 IF T="AAAA"
Begin DoDot:2
+7 ;Get IPv6 address
SET X=$SYSTEM.INetInfo.HostNameToAddr(N,2,0)
+8 ;Format IPv6 address
SET Y=$$FORCEIP6^XLFIPV(X)
End DoDot:2
+9 ;Get IPv4 address
IF ($PIECE(Y,":")="0000")!(T="A")
SET Y=$SYSTEM.INetInfo.HostNameToAddr(N,1,0)
End DoDot:1
QUIT Y
+10 ;Non-cache systems and lookups other than "A" or "AAAA"
+11 DO NS(.XLF,N,T)
+12 SET Y=""
FOR I=1:1:XLF("ANCOUNT")
if $DATA(XLF("AN"_I_"DATA"))
SET Y=Y_XLF("AN"_I_"DATA")_","
+13 QUIT $EXTRACT(Y,1,$LENGTH(Y)-1)
+14 ;
MAIL(RET,N) ;Get the MX address for a domain
+1 ;RET is the return array
+2 NEW XLF,Y,I,T
SET XLF=""
SET T="MX"
+3 DO NS(.XLF,N,T)
+4 SET RET=0
SET I=0
FOR
SET I=$ORDER(XLF("P",I))
if I'>0
QUIT
Begin DoDot:1
+5 SET N=XLF("P",I)
SET RET(I)=N_"^"_$GET(XLF("B",N))
SET RET=RET+1
End DoDot:1
+6 QUIT
+7 ;
NS(XL,NAME,QTYPE,XLFLOG) ;NAME LOOKUP
+1 ;XL is the return array, NAME is the name to lookup,
+2 ;QTYPE is type of lookup, XLFLOG is a debug array returned.
+3 NEW RI,DNS,CNT,POP
if '$DATA(XLFLOG)
NEW XLFLOG
SET XL("ANCOUNT")=0
SET CNT=1
+4 DO SAVEDEV
NS2 ;
+1 SET DNS=$$GETDNS(CNT)
IF DNS=""
GOTO EXIT
+2 DO LOG("Call server: "_DNS)
+3 DO CALL^%ZISTCP(DNS,53)
IF POP
SET CNT=CNT+1
GOTO NS2
+4 DO LOG("Got connection, Send message")
+5 ; Uses "AAAA" type for IPv6 if QTYPE is not defined
DO BUILD(NAME,$GET(QTYPE,"AAAA"))
DO LOG("Wait for reply")
+6 ;Close part of READ
+7 DO READ
DO DECODE
+8 DO RESDEV
DO LOG("Returned question: "_$GET(XL("QD1NAME")))
+9 QUIT
EXIT DO RESDEV
+1 QUIT
+2 ;
BUILD(Y,T) ;BUILD A QUERY
+1 ; ID,PARAM,#of?, #ofA, #of Auth, #of add,
+2 NEW X,%,MSG,I
+3 ;Header
SET X=" M"_$CHAR(1,0)_$CHAR(0,1)_$CHAR(0,0)_$CHAR(0,0)_$CHAR(0,0)
+4 IF $EXTRACT(Y,$LENGTH(Y))'="."
if $EXTRACT(Y,$LENGTH(Y))'="."
SET Y=Y_"."
+5 ;FQDN Address
FOR I=1:1:$LENGTH(Y,".")
SET %=$PIECE(Y,".",I)
if $LENGTH(%)
SET X=X_$CHAR($LENGTH(%))_%
+6 ;End of FQDN address
SET X=X_$CHAR(0)
+7 ;Type A=1, NS=2, CNAME=5, MX=15, AAAA=28
+8 ;type and class
SET MSG=X_$CHAR(0,$$TYPECODE(T))_$CHAR(0,1)
+9 DO LOG("msg: "_MSG)
+10 USE IO
SET %=$LENGTH(MSG)
WRITE $CHAR(%\256,%#256)_MSG,!
+11 QUIT
READ ;
+1 ;ZEXCEPT: I,RI,XL ;Global variables within this routine
+2 NEW L1,L2,X,$ETRAP
SET $ETRAP="G RDERR"
KILL RI
SET RI=0
+3 USE IO
READ L1#2:20
IF '$TEST
DO LOG("Time-out")
GOTO RDERR
+4 ;get msg length
SET RI=$ASCII(L1,1)*256+$ASCII(L1,2)
+5 FOR I=1:1:6
READ L2#2:20
if '$TEST
QUIT
SET XL($PIECE("ID^CODE^QDCOUNT^ANCOUNT^NSCOUNT^ARCOUNT","^",I))=$SELECT(I>2:$$WBN(L2),I=2:$$BIN16(L2),1:L2)
+6 IF '$TEST
DO LOG("Time-out")
GOTO RDERR
+7 DO LOG("Return msg length: "_RI)
+8 ;or use X#1 and $A(X)
FOR I=13:1:RI
USE IO
READ *X:20
if '$TEST
QUIT
SET RI(I)=X
RDERR ;End of read
+1 DO CLOSE^%ZISTCP
+2 QUIT
DECODE ;
+1 ;ZEXCEPT: XL ;Global variable within this routine
+2 NEW I,IX,X,Y,Z,NN,NN2
if RI'>7
QUIT
+3 IF $GET(XL("ID"))'=" M"
SET XL("ERR")="Bad Response"
DO LOG(XL("ERR"))
QUIT
+4 ;Decode the header
+5 SET Z=XL("CODE")
SET XL("QR")=$EXTRACT(Z,1)
SET XL("Opcode")=$EXTRACT(Z,2,5)
SET XL("AA")=$EXTRACT(Z,6)
SET XL("TC")=$EXTRACT(Z,7)
SET XL("RD")=$EXTRACT(Z,8)
SET XL("RA")=$EXTRACT(Z,9)
SET XL("RCODE")=$EXTRACT(Z,13,16)
+6 ;The Question section
+7 SET IX=13
+8 FOR NN2=1:1:XL("QDCOUNT")
DO QD("QD"_NN2)
+9 FOR NN="AN","NS","AR"
IF $GET(XL(NN_"COUNT"))
FOR NN2=1:1:XL(NN_"COUNT")
DO RR(NN_NN2)
+10 QUIT
+11 ;
QD(NSP) ;Decode the Question section
+1 ;ZEXCEPT: IX,RI,XL ;Global variables within this routine
+2 NEW Y
+3 SET Y=""
SET IX=IX+$$NAME(IX,.Y,1)
SET XL(NSP_"NAME")=Y
+4 SET XL(NSP_"TYPE")=$$BN(RI(IX),RI(IX+1))
SET IX=IX+2
+5 SET XL(NSP_"CLASS")=$$BN(RI(IX),RI(IX+1))
SET IX=IX+2
+6 QUIT
RR(NSP) ;
+1 ;ZEXCEPT: IX,RI,X,XL ;Global variables within this routine
+2 NEW Y,NA
+3 SET Y=""
SET IX=IX+$$NAME(IX,.Y,1)
SET XL(NSP_"NAME")=Y
SET NA=Y
+4 SET XL(NSP_"TYPE")=$$BN(RI(IX),RI(IX+1))
SET IX=IX+2
+5 SET XL(NSP_"CLASS")=$$BN(RI(IX),RI(IX+1))
SET IX=IX+2
+6 SET Y=RI(IX)*256+RI(IX+1)
SET Y=Y*256+RI(IX+2)
SET Y=Y*256+RI(IX+3)
+7 SET XL(NSP_"TTL")=Y
SET IX=IX+4
+8 SET (X,XL(NSP_"LENGTH"))=$$BN(RI(IX),RI(IX+1))
SET IX=IX+2
if X=0
QUIT
+9 ; IPv4 address
IF XL(NSP_"TYPE")=1
Begin DoDot:1
+10 SET XL(NSP_"DATA")=RI(IX)_"."_RI(IX+1)_"."_RI(IX+2)_"."_RI(IX+3)
SET XL("B",NA)=XL(NSP_"DATA")
End DoDot:1
+11 ; IPv6 address
IF XL(NSP_"TYPE")=28
Begin DoDot:1
+12 SET XL(NSP_"DATA")=$$H1(RI(IX))_$$H1(RI(IX+1))_":"_$$H1(RI(IX+2))_$$H1(RI(IX+3))_":"
+13 SET XL(NSP_"DATA")=XL(NSP_"DATA")_$$H1(RI(IX+4))_$$H1(RI(IX+5))_":"_$$H1(RI(IX+6))_$$H1(RI(IX+7))_":"
+14 SET XL(NSP_"DATA")=XL(NSP_"DATA")_$$H1(RI(IX+8))_$$H1(RI(IX+9))_":"_$$H1(RI(IX+10))_$$H1(RI(IX+11))_":"
+15 SET XL(NSP_"DATA")=XL(NSP_"DATA")_$$H1(RI(IX+12))_$$H1(RI(IX+13))_":"_$$H1(RI(IX+14))_$$H1(RI(IX+15))
+16 SET XL("B",NA)=XL(NSP_"DATA")
End DoDot:1
+17 ; MX entry
IF XL(NSP_"TYPE")=15
DO MX(IX)
+18 SET IX=IX+XL(NSP_"LENGTH")
+19 QUIT
NAME(I,NM,F) ;Decode a NAME section
+1 ;ZEXCEPT: RI ;Global variable within this routine
+2 NEW P,T,Y,X
SET NM=$GET(NM)
if F
SET T=0
+3 ;Use X as flag to escape recursion.
FOR
SET X=RI(I)
if (X=0)&F
SET T=T+1
if X=0
QUIT
Begin DoDot:1
+4 IF (X\64)=3
SET X=$$NAME((X#64)*256+RI(I+1)+1,.NM,0)
SET X=0
if F
SET T=T+2
QUIT
+5 SET NM=NM_$$PART(I+1,X)
SET I=I+X+1
if F
SET T=T+X+1
End DoDot:1
if X=0
QUIT
+6 QUIT $GET(T)
+7 ;
MX(IX) ;Hide IX changes
+1 ;ZEXCEPT: NSP,RI,XL ;Global variables within this routine
+2 NEW Y
SET Y=$$BN(RI(IX),RI(IX+1))
+3 FOR
if '$DATA(XL("P",Y))
QUIT
SET Y=Y+1
+4 SET XL(NSP_"PREF")=Y
SET IX=IX+2
+5 SET Y=""
SET IX=IX+$$NAME(IX,.Y,1)
SET XL(NSP_"NAME")=Y
SET XL("P",XL(NSP_"PREF"))=Y
+6 QUIT
+7 ;
BN(Z1,Z2) ;Convert two binary char 16 bit number into ASCII number
+1 QUIT Z1*256+Z2
+2 ;
WBN(Z1) ;Convert two byte string to a ASCII number
+1 QUIT $ASCII(Z1,1)*256+$ASCII(Z1,2)
+2 ;
H2(Z2) ;Convert 2 byte string to HEX
+1 NEW B
SET B=$ASCII(Z2,1)*256+$ASCII(Z2,2)
+2 QUIT $$H(B)
+3 ;
H1(Z1) ;Convert decimal number <= 256 to two digit HEX number
+1 NEW Y
SET Y=$$CNV^XLFUTL(Z1,16)
+2 QUIT $$RJ^XLFSTR(Y,2,"0")
+3 ;
H(Z1) QUIT $$BASE^XLFUTL(Z1,10,16)
+1 ;
BIN16(S) ;Convert two byte string to 16 bit binary
+1 NEW K,Y
SET S=$ASCII(S,1)*256+$ASCII(S,2)
SET Y=""
+2 FOR K=0:1:15
SET Y=(S\(2**K)#2)_Y
+3 QUIT Y
+4 ;
PART(S,L) ;
+1 ;ZEXCEPT: RI ;Global variable within this routine
+2 NEW R,A
SET R=""
FOR A=S:1:S+L-1
SET R=R_$CHAR(RI(A))
+3 QUIT R_"."
+4 ;
TYPECODE(T) ;
+1 ;1=A:IPv4 address,2=NS:nameserver,5=CNAME,15=MX:mail exchange,28=AAAA:IPv6 address
+2 IF +T
QUIT $SELECT(T=1:"A",T=2:"NS",T=5:"CNAME",T=15:"MX",T=28:"AAAA",1:"ZZ")
+3 QUIT $SELECT(T="A":1,T="NS":2,T="CNAME":5,T="MX":15,T="AAAA":28,1:1)
+4 ;
CLASS(T) ;
+1 QUIT $SELECT(T=1:"IN",1:"ZZ")
+2 ;
GETDNS(I) ;Get the address of our DNS
+1 NEW L
SET L=$GET(^XTV(8989.3,1,"DNS"))
+2 QUIT $PIECE(L,",",I)
+3 ;
SW(T,H,V) ;
+1 WRITE ?T,$JUSTIFY(H,8),V
+2 QUIT
SAVEDEV ;Save calling device
+1 if '$DATA(IO(0))
DO HOME^%ZIS
DO SAVDEV^%ZISUTL("XLFNSLK")
+2 QUIT
RESDEV ;Restore calling device
+1 DO USE^%ZISUTL("XLFNSLK")
DO RMDEV^%ZISUTL("XLFNSLK")
+2 KILL IO("CLOSE")
+3 QUIT
LOG(M,XLFLOG) ;Log Debug messages
+1 ;ZEXCEPT: XLFLOG ;Global variable within this routine
+2 SET XLFLOG=$GET(XLFLOG)+1
SET XLFLOG(XLFLOG)=M
+3 QUIT
+4 ;
