Mercurial > emacs

comparison lisp/net/dns.el @ 86917:439fa1afe05a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Refill copyright. (top-level): Don't require mm-util, or cl when compiling. (dns-write-name, dns-read, dns-read-type, query-dns): Replace mm-with-unibyte-buffer with its expansion. (query-dns): Replace decf and ignore-errors with non-cl equivalents.
author Glenn Morris <rgm@gnu.org>
date Sat, 01 Dec 2007 21:02:07 +0000
parents b48d018b85e2
children 107ccd98fa12
comparison
equal deleted inserted replaced
86916:62c3928ba4fb 86917:439fa1afe05a
1 ;;; dns.el --- Domain Name Service lookups 1 ;;; dns.el --- Domain Name Service lookups
2 2
3 ;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. 3 ;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
4 ;; Free Software Foundation, Inc.
4 5
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> 6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
6 ;; Keywords: network 7 ;; Keywords: network
7 8
8 ;; This file is part of GNU Emacs. 9 ;; This file is part of GNU Emacs.
23 ;; Boston, MA 02110-1301, USA. 24 ;; Boston, MA 02110-1301, USA.
24 25
25 ;;; Commentary: 26 ;;; Commentary:
26 27
27 ;;; Code: 28 ;;; Code:
28
29 (eval-when-compile (require 'cl))
30
31 (require 'mm-util)
32 29
33 (defvar dns-timeout 5 30 (defvar dns-timeout 5
34 "How many seconds to wait when doing DNS queries.") 31 "How many seconds to wait when doing DNS queries.")
35 32
36 (defvar dns-servers nil 33 (defvar dns-servers nil
103 (dns-write-bytes (length part)) 100 (dns-write-bytes (length part))
104 (insert part)) 101 (insert part))
105 (dns-write-bytes 0)) 102 (dns-write-bytes 0))
106 103
107 (defun dns-read-string-name (string buffer) 104 (defun dns-read-string-name (string buffer)
108 (mm-with-unibyte-buffer 105 (let (default-enable-multibyte-characters)
109 (insert string) 106 (with-temp-buffer
110 (goto-char (point-min)) 107 (insert string)
111 (dns-read-name buffer))) 108 (goto-char (point-min))
109 (dns-read-name buffer))))
112 110
113 (defun dns-read-name (&optional buffer) 111 (defun dns-read-name (&optional buffer)
114 (let ((ended nil) 112 (let ((ended nil)
115 (name nil) 113 (name nil)
116 length) 114 length)
186 (goto-char (point-min)) 184 (goto-char (point-min))
187 (dns-write-bytes (buffer-size) 2)) 185 (dns-write-bytes (buffer-size) 2))
188 (buffer-string))) 186 (buffer-string)))
189 187
190 (defun dns-read (packet) 188 (defun dns-read (packet)
191 (mm-with-unibyte-buffer 189 (let (default-enable-multibyte-characters)
192 (let ((spec nil) 190 (with-temp-buffer
193 queries answers authorities additionals) 191 (let ((spec nil)
194 (insert packet) 192 queries answers authorities additionals)
195 (goto-char (point-min)) 193 (insert packet)
196 (push (list 'id (dns-read-bytes 2)) spec) 194 (goto-char (point-min))
197 (let ((byte (dns-read-bytes 1))) 195 (push (list 'id (dns-read-bytes 2)) spec)
198 (push (list 'response-p (if (zerop (logand byte (lsh 1 7))) nil t)) 196 (let ((byte (dns-read-bytes 1)))
199 spec) 197 (push (list 'response-p (if (zerop (logand byte (lsh 1 7))) nil t))
200 (let ((opcode (logand byte (lsh 7 3)))) 198 spec)
201 (push (list 'opcode 199 (let ((opcode (logand byte (lsh 7 3))))
202 (cond ((eq opcode 0) 'query) 200 (push (list 'opcode
203 ((eq opcode 1) 'inverse-query) 201 (cond ((eq opcode 0) 'query)
204 ((eq opcode 2) 'status))) 202 ((eq opcode 1) 'inverse-query)
205 spec)) 203 ((eq opcode 2) 'status)))
206 (push (list 'authoritative-p (if (zerop (logand byte (lsh 1 2))) 204 spec))
207 nil t)) spec) 205 (push (list 'authoritative-p (if (zerop (logand byte (lsh 1 2)))
208 (push (list 'truncated-p (if (zerop (logand byte (lsh 1 2))) nil t)) 206 nil t)) spec)
209 spec) 207 (push (list 'truncated-p (if (zerop (logand byte (lsh 1 2))) nil t))
210 (push (list 'recursion-desired-p 208 spec)
211 (if (zerop (logand byte (lsh 1 0))) nil t)) spec)) 209 (push (list 'recursion-desired-p
212 (let ((rc (logand (dns-read-bytes 1) 15))) 210 (if (zerop (logand byte (lsh 1 0))) nil t)) spec))
213 (push (list 'response-code 211 (let ((rc (logand (dns-read-bytes 1) 15)))
214 (cond 212 (push (list 'response-code
215 ((eq rc 0) 'no-error) 213 (cond
216 ((eq rc 1) 'format-error) 214 ((eq rc 0) 'no-error)
217 ((eq rc 2) 'server-failure) 215 ((eq rc 1) 'format-error)
218 ((eq rc 3) 'name-error) 216 ((eq rc 2) 'server-failure)
219 ((eq rc 4) 'not-implemented) 217 ((eq rc 3) 'name-error)
220 ((eq rc 5) 'refused))) 218 ((eq rc 4) 'not-implemented)
221 spec)) 219 ((eq rc 5) 'refused)))
222 (setq queries (dns-read-bytes 2)) 220 spec))
223 (setq answers (dns-read-bytes 2)) 221 (setq queries (dns-read-bytes 2))
224 (setq authorities (dns-read-bytes 2)) 222 (setq answers (dns-read-bytes 2))
225 (setq additionals (dns-read-bytes 2)) 223 (setq authorities (dns-read-bytes 2))
226 (let ((qs nil)) 224 (setq additionals (dns-read-bytes 2))
227 (dotimes (i queries) 225 (let ((qs nil))
228 (push (list (dns-read-name) 226 (dotimes (i queries)
229 (list 'type (dns-inverse-get (dns-read-bytes 2) 227 (push (list (dns-read-name)
230 dns-query-types)) 228 (list 'type (dns-inverse-get (dns-read-bytes 2)
231 (list 'class (dns-inverse-get (dns-read-bytes 2) 229 dns-query-types))
232 dns-classes))) 230 (list 'class (dns-inverse-get (dns-read-bytes 2)
233 qs)) 231 dns-classes)))
234 (push (list 'queries qs) spec)) 232 qs))
235 (dolist (slot '(answers authorities additionals)) 233 (push (list 'queries qs) spec))
236 (let ((qs nil) 234 (dolist (slot '(answers authorities additionals))
237 type) 235 (let ((qs nil)
238 (dotimes (i (symbol-value slot)) 236 type)
239 (push (list (dns-read-name) 237 (dotimes (i (symbol-value slot))
240 (list 'type 238 (push (list (dns-read-name)
241 (setq type (dns-inverse-get (dns-read-bytes 2) 239 (list 'type
242 dns-query-types))) 240 (setq type (dns-inverse-get (dns-read-bytes 2)
243 (list 'class (dns-inverse-get (dns-read-bytes 2) 241 dns-query-types)))
244 dns-classes)) 242 (list 'class (dns-inverse-get (dns-read-bytes 2)
245 (list 'ttl (dns-read-bytes 4)) 243 dns-classes))
246 (let ((length (dns-read-bytes 2))) 244 (list 'ttl (dns-read-bytes 4))
247 (list 'data 245 (let ((length (dns-read-bytes 2)))
248 (dns-read-type 246 (list 'data
249 (buffer-substring 247 (dns-read-type
250 (point) 248 (buffer-substring
251 (progn (forward-char length) (point))) 249 (point)
252 type)))) 250 (progn (forward-char length) (point)))
253 qs)) 251 type))))
254 (push (list slot qs) spec))) 252 qs))
255 (nreverse spec)))) 253 (push (list slot qs) spec)))
254 (nreverse spec)))))
256 255
257 (defun dns-read-int32 () 256 (defun dns-read-int32 ()
258 ;; Full 32 bit Integers can't be handled by Emacs. If we use 257 ;; Full 32 bit Integers can't be handled by Emacs. If we use
259 ;; floats, it works. 258 ;; floats, it works.
260 (format "%.0f" (+ (* (dns-read-bytes 1) 16777216.0) 259 (format "%.0f" (+ (* (dns-read-bytes 1) 16777216.0)
262 261
263 (defun dns-read-type (string type) 262 (defun dns-read-type (string type)
264 (let ((buffer (current-buffer)) 263 (let ((buffer (current-buffer))
265 (point (point))) 264 (point (point)))
266 (prog1 265 (prog1
267 (mm-with-unibyte-buffer 266 (let (default-enable-multibyte-characters)
268 (insert string) 267 (with-temp-buffer
269 (goto-char (point-min)) 268 (insert string)
270 (cond 269 (goto-char (point-min))
271 ((eq type 'A) 270 (cond
272 (let ((bytes nil)) 271 ((eq type 'A)
273 (dotimes (i 4) 272 (let ((bytes nil))
274 (push (dns-read-bytes 1) bytes)) 273 (dotimes (i 4)
275 (mapconcat 'number-to-string (nreverse bytes) "."))) 274 (push (dns-read-bytes 1) bytes))
276 ((eq type 'AAAA) 275 (mapconcat 'number-to-string (nreverse bytes) ".")))
277 (let (hextets) 276 ((eq type 'AAAA)
278 (dotimes (i 8) 277 (let (hextets)
279 (push (dns-read-bytes 2) hextets)) 278 (dotimes (i 8)
280 (mapconcat (lambda (n) (format "%x" n)) (nreverse hextets) ":"))) 279 (push (dns-read-bytes 2) hextets))
281 ((eq type 'SOA) 280 (mapconcat (lambda (n) (format "%x" n))
282 (list (list 'mname (dns-read-name buffer)) 281 (nreverse hextets) ":")))
283 (list 'rname (dns-read-name buffer)) 282 ((eq type 'SOA)
284 (list 'serial (dns-read-int32)) 283 (list (list 'mname (dns-read-name buffer))
285 (list 'refresh (dns-read-int32)) 284 (list 'rname (dns-read-name buffer))
286 (list 'retry (dns-read-int32)) 285 (list 'serial (dns-read-int32))
287 (list 'expire (dns-read-int32)) 286 (list 'refresh (dns-read-int32))
288 (list 'minimum (dns-read-int32)))) 287 (list 'retry (dns-read-int32))
289 ((eq type 'SRV) 288 (list 'expire (dns-read-int32))
290 (list (list 'priority (dns-read-bytes 2)) 289 (list 'minimum (dns-read-int32))))
291 (list 'weight (dns-read-bytes 2)) 290 ((eq type 'SRV)
292 (list 'port (dns-read-bytes 2)) 291 (list (list 'priority (dns-read-bytes 2))
293 (list 'target (dns-read-name buffer)))) 292 (list 'weight (dns-read-bytes 2))
294 ((eq type 'MX) 293 (list 'port (dns-read-bytes 2))
295 (cons (dns-read-bytes 2) (dns-read-name buffer))) 294 (list 'target (dns-read-name buffer))))
296 ((or (eq type 'CNAME) (eq type 'NS) (eq type 'PTR)) 295 ((eq type 'MX)
297 (dns-read-string-name string buffer)) 296 (cons (dns-read-bytes 2) (dns-read-name buffer)))
298 (t string))) 297 ((or (eq type 'CNAME) (eq type 'NS) (eq type 'PTR))
298 (dns-read-string-name string buffer))
299 (t string))))
299 (goto-char point)))) 300 (goto-char point))))
300 301
301 (defun dns-parse-resolv-conf () 302 (defun dns-parse-resolv-conf ()
302 (when (file-exists-p "/etc/resolv.conf") 303 (when (file-exists-p "/etc/resolv.conf")
303 (with-temp-buffer 304 (with-temp-buffer
375 ".in-addr.arpa") 376 ".in-addr.arpa")
376 type 'PTR)) 377 type 'PTR))
377 378
378 (if (not dns-servers) 379 (if (not dns-servers)
379 (message "No DNS server configuration found") 380 (message "No DNS server configuration found")
380 (mm-with-unibyte-buffer 381 (let (default-enable-multibyte-characters)
381 (let ((process (condition-case () 382 (with-temp-buffer
382 (dns-make-network-process (car dns-servers)) 383 (let ((process (condition-case ()
383 (error 384 (dns-make-network-process (car dns-servers))
384 (message "dns: Got an error while trying to talk to %s" 385 (error
385 (car dns-servers)) 386 (message
386 nil))) 387 "dns: Got an error while trying to talk to %s"
387 (tcp-p (and (not (fboundp 'make-network-process)) 388 (car dns-servers))
388 (not (featurep 'xemacs)))) 389 nil)))
389 (step 100) 390 (tcp-p (and (not (fboundp 'make-network-process))
390 (times (* dns-timeout 1000)) 391 (not (featurep 'xemacs))))
391 (id (random 65000))) 392 (step 100)
392 (when process 393 (times (* dns-timeout 1000))
393 (process-send-string 394 (id (random 65000)))
394 process 395 (when process
395 (dns-write `((id ,id) 396 (process-send-string
396 (opcode query) 397 process
397 (queries ((,name (type ,type)))) 398 (dns-write `((id ,id)
398 (recursion-desired-p t)) 399 (opcode query)
399 tcp-p)) 400 (queries ((,name (type ,type))))
400 (while (and (zerop (buffer-size)) 401 (recursion-desired-p t))
401 (> times 0)) 402 tcp-p))
402 (sit-for (/ step 1000.0)) 403 (while (and (zerop (buffer-size))
403 (accept-process-output process 0 step) 404 (> times 0))
404 (decf times step)) 405 (sit-for (/ step 1000.0))
405 (ignore-errors 406 (accept-process-output process 0 step)
406 (delete-process process)) 407 (setq times (- times step)))
407 (when (and tcp-p 408 (condition-case nil
408 (>= (buffer-size) 2)) 409 (delete-process process)
409 (goto-char (point-min)) 410 (error nil))
410 (delete-region (point) (+ (point) 2))) 411 (when (and tcp-p
411 (when (and (>= (buffer-size) 2) 412 (>= (buffer-size) 2))
412 ;; We had a time-out. 413 (goto-char (point-min))
413 (> times 0)) 414 (delete-region (point) (+ (point) 2)))
414 (let ((result (dns-read (buffer-string)))) 415 (when (and (>= (buffer-size) 2)
415 (if fullp 416 ;; We had a time-out.
416 result 417 (> times 0))
417 (let ((answer (car (dns-get 'answers result)))) 418 (let ((result (dns-read (buffer-string))))
418 (when (eq type (dns-get 'type answer)) 419 (if fullp
419 (if (eq type 'TXT) 420 result
420 (dns-get-txt-answer (dns-get 'answers result)) 421 (let ((answer (car (dns-get 'answers result))))
421 (dns-get 'data answer)))))))))))) 422 (when (eq type (dns-get 'type answer))
423 (if (eq type 'TXT)
424 (dns-get-txt-answer (dns-get 'answers result))
425 (dns-get 'data answer)))))))))))))
422 426
423 (provide 'dns) 427 (provide 'dns)
424 428
425 ;;; arch-tag: d0edd0c4-4cce-4538-ae92-06c3356ee80a 429 ;;; arch-tag: d0edd0c4-4cce-4538-ae92-06c3356ee80a
426 ;;; dns.el ends here 430 ;;; dns.el ends here