source: FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XLFNSLK.m@ 631

Last change on this file since 631 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 5.4 KB
Line 
1XLFNSLK ;ISF/RWF - Calling a DNS server for name lookup ;5/21/07 14:47
2 ;;8.0;KERNEL;**142,151,425**;Jul 10, 1995;Build 18
3 ;
4TEST ;Test entry
5 N XLF,XL1,XL3,Y,I S (XLF,XL3)=""
6 R !,"Enter a IP address to lookup: www.va.gov//",XL1:DTIME S:XL1="" XL1="www.va.gov" Q:XL1["^"
7 W !,"Looking up ",XL1 D NS(.XLF,XL1,"A",.XL3)
8 S XL1="XL3" F S XL1=$Q(@XL1) Q:XL1="" W !,XL1," = ",@XL1
9 S Y="" F S Y=$O(XLF("B",Y)) Q:Y="" W !,?5,Y," > ",XLF("B",Y)
10 Q
11 ;
12ADDRESS(N,T) ;Get a IP address from a name
13 N XLF,Y,I S XLF="",T=$G(T,"A")
14 I ^%ZOSF("OS")["OpenM",T="A" D Q $P(Y,",")
15 . X "S Y=$ZU(54,13,N)"
16 D NS(.XLF,N,T)
17 S Y="" F I=1:1:XLF("ANCOUNT") S:$D(XLF("AN"_I_"DATA")) Y=Y_XLF("AN"_I_"DATA")_","
18 Q $E(Y,1,$L(Y)-1)
19 ;
20MAIL(RET,N) ;Get the MX address for a domain
21 ;RET is the return array
22 N XLF,Y,I,T S XLF="",T="MX"
23 D NS(.XLF,N,T)
24 S RET=0,I=0 F S I=$O(XLF("P",I)) Q:I'>0 D
25 . S N=XLF("P",I),RET(I)=N_"^"_$G(XLF("B",N)),RET=RET+1
26 Q
27 ;
28NS(XL,NAME,QTYPE,XLFLOG) ;NAME LOOKUP
29 ;XL is the return array, NAME is the name to lookup,
30 ;QTYPE is type of lookup, XLFLOG is a debug array returned.
31 N RI,DNS,CNT,POP N:'$D(XLFLOG) XLFLOG S XL("ANCOUNT")=0,CNT=1
32 D SAVEDEV
33NS2 S DNS=$$GETDNS(CNT) I DNS="" G EXIT
34 D LOG("Call server: "_DNS)
35 D CALL^%ZISTCP(DNS,53) I POP S CNT=CNT+1 G NS2
36 D LOG("Got connection, Send message")
37 D BUILD(NAME,$G(QTYPE,"A")),LOG("Wait for reply")
38 ;Close part of READ
39 D READ,DECODE
40 D RESDEV,LOG("Returned question: "_$G(XL("QD1NAME")))
41 Q
42EXIT D RESDEV
43 Q
44 ;
45BUILD(Y,T) ;BUILD A QUEARY
46 ; ID,PARAM,#of?, #ofA, #of Auth, #of add,
47 N X,%,MSG,I
48 S X=" M"_$C(1,0)_$C(0,1)_$C(0,0)_$C(0,0)_$C(0,0) ;Header
49 I $E(Y,$L(Y))'="." S:$E(Y,$L(Y))'="." Y=Y_"."
50 F I=1:1:$L(Y,".") S %=$P(Y,".",I) S:$L(%) X=X_$C($L(%))_% ;Address
51 S X=X_$C(0) ;End of address
52 ;Type A=1, NS=2, CNAME=5, MX=15
53 S MSG=X_$C(0,$$TYPECODE(T))_$C(0,1) ;type and class
54 D LOG("msg: "_MSG)
55 U IO S %=$L(MSG) W $C(%\256,%#256)_MSG,!
56 Q
57READ ;
58 N L1,L2,X,$ET S $ET="G RDERR" K RI S RI=0
59 U IO R L1#2:20 I '$T D LOG("Time-out") G RDERR
60 S RI=$A(L1,1)*256+$A(L1,2) ;get msg length
61 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)
62 I '$T D LOG("Time-out") G RDERR
63 D LOG("Return msg length: "_RI)
64 F I=13:1:RI U IO R *X:20 Q:'$T S RI(I)=X ;or use X#1 and $A(X)
65RDERR ;End of read
66 D CLOSE^%ZISTCP
67 Q
68DECODE ;
69 N I,IX,X,Y,Z,NN,NN2 Q:RI'>7
70 I $G(XL("ID"))'=" M" S XL("ERR")="Bad Response" D LOG(XL("ERR")) Q
71 ;Decode the header
72 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)
73 ;The Question section
74 S IX=13
75 F NN2=1:1:XL("QDCOUNT") D QD("QD"_NN2)
76 F NN="AN","NS","AR" I $G(XL(NN_"COUNT")) F NN2=1:1:XL(NN_"COUNT") D RR(NN_NN2)
77 Q
78 ;
79QD(NSP) ;Decode the Question section
80 N Y
81 S Y="",IX=IX+$$NAME(IX,.Y,1),XL(NSP_"NAME")=Y
82 S XL(NSP_"TYPE")=$$BN(RI(IX),RI(IX+1)),IX=IX+2
83 S XL(NSP_"CLASS")=$$BN(RI(IX),RI(IX+1)),IX=IX+2
84 Q
85RR(NSP) ;
86 N Y,NA
87 S Y="",IX=IX+$$NAME(IX,.Y,1),XL(NSP_"NAME")=Y,NA=Y
88 S XL(NSP_"TYPE")=$$BN(RI(IX),RI(IX+1)),IX=IX+2
89 S XL(NSP_"CLASS")=$$BN(RI(IX),RI(IX+1)),IX=IX+2
90 S Y=RI(IX)*256+RI(IX+1),Y=Y*256+RI(IX+2),Y=Y*256+RI(IX+3)
91 S XL(NSP_"TTL")=Y,IX=IX+4
92 S (X,XL(NSP_"LENGTH"))=$$BN(RI(IX),RI(IX+1)),IX=IX+2 Q:X=0
93 I XL(NSP_"TYPE")=1 S XL(NSP_"DATA")=RI(IX)_"."_RI(IX+1)_"."_RI(IX+2)_"."_RI(IX+3),XL("B",NA)=XL(NSP_"DATA")
94 I XL(NSP_"TYPE")=15 D MX(IX)
95 S IX=IX+XL(NSP_"LENGTH")
96 Q
97NAME(I,NM,F) ;Decode a NAME section
98 N P,T,Y,X S NM=$G(NM) S:F T=0
99 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.
100 . I (X\64)=3 S X=$$NAME((X#64)*256+RI(I+1)+1,.NM,0),X=0 S:F T=T+2 Q
101 . S NM=NM_$$PART(I+1,X),I=I+X+1 S:F T=T+X+1
102 Q $G(T)
103 ;
104MX(IX) ;Hide IX changes
105 N Y S Y=$$BN(RI(IX),RI(IX+1))
106 F Q:'$D(XL("P",Y)) S Y=Y+1
107 S XL(NSP_"PREF")=Y,IX=IX+2
108 S Y="",IX=IX+$$NAME(IX,.Y,1),XL(NSP_"NAME")=Y,XL("P",XL(NSP_"PREF"))=Y
109 Q
110 ;
111BN(Z1,Z2) ;Convert two binary char 16 bit number into ASCII number
112 Q Z1*256+Z2
113 ;
114WBN(Z1) ;Convert two byte string to a ASCII number
115 Q $A(Z1,1)*256+$A(Z1,2)
116 ;
117H2(Z2) ;Convert 2 byte string to HEX
118 N B S B=$A(Z2,1)*256+$A(Z2,2)
119 Q $$H(B)
120 ;
121H(Z1) Q $$BASE^XLFUTL(Z1,10,16)
122 ;
123BIN16(S) ;Convert two byte string to 16 bit binary
124 N K,Y S S=$A(S,1)*256+$A(S,2),Y=""
125 F K=0:1:15 S Y=(S\(2**K)#2)_Y
126 Q Y
127 ;
128PART(S,L) ;
129 N R,A S R="" F A=S:1:S+L-1 S R=R_$C(RI(A))
130 Q R_"."
131 ;
132TYPECODE(T) ;
133 ;1=A:address,2=NS:nameserver,5=CNAME,15=MX:mail exchange
134 I +T Q $S(T=1:"A",T=2:"NS",T=5:"CNAME",T=15:"MX",1:"ZZ")
135 Q $S(T="A":1,T="NS":2,T="CNAME":5,T="MX":15,1:1)
136 ;
137CLASS(T) ;
138 Q $S(T=1:"IN",1:"ZZ")
139 ;
140GETDNS(I) ;Get the address of our DNS
141 N L S L=$G(^XTV(8989.3,1,"DNS"))
142 Q $P(L,",",I)
143 ;
144SHOW ;LIST RI AND XL
145 S O1=RI\3+1,O2=O1*2
146 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 !
147 Q
148SW(T,H,V) ;
149 W ?T,$J(H,8),V
150 Q
151SAVEDEV ;Save calling device
152 D:'$D(IO(0)) HOME^%ZIS D SAVDEV^%ZISUTL("XLFNSLK")
153 Q
154RESDEV ;Restore calling device
155 D USE^%ZISUTL("XLFNSLK"),RMDEV^%ZISUTL("XLFNSLK")
156 K IO("CLOSE")
157 Q
158LOG(M) ;Log Debug messages
159 S XLFLOG=$G(XLFLOG)+1,XLFLOG(XLFLOG)=M
160 Q
161 ;
162POST ;Stuff a DNS address during install POST init.
163 N DIC,DR,DIQ,XLF,DIE
164 S XLF=$P($$PARAM^HLCS2,U,3)
165 I XLF="T" D BMES^XPDUTL("Test Account DNS address not installed.") Q
166 S DIC=8989.3,DR=51,DA=1,DIQ="XLF(" D EN^DIQ1 I $L(XLF(8989.3,1,51)) Q
167 S DR="51///10.3.21.192",DIE="^XTV(8989.3,",DA=1 D ^DIE
168 D BMES^XPDUTL("DNS address installed.")
169 Q
Note: See TracBrowser for help on using the repository browser.