X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;ds=sidebyside;f=lisp%2Fdns.el;h=e5acf4e880c51ed54e57b7c15690a9b02bca4b9a;hb=8b87e18f7b6e6fced757c12428271a9433d335bd;hp=475909a70d3f17792ab8cf644e1d35b5cbb183fd;hpb=397ec0dada9ed9765e0d8474bcf2eed2c728213f;p=gnus

diff --git a/lisp/dns.el b/lisp/dns.el
index 475909a70..e5acf4e88 100644
--- a/lisp/dns.el
+++ b/lisp/dns.el
@@ -1,5 +1,5 @@
 ;;; dns.el --- Domain Name Service lookups
-;; Copyright (C) 2002 Free Software Foundation, Inc.
+;; Copyright (C) 2002, 2003 Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; Keywords: network
@@ -25,6 +25,8 @@
 
 ;;; Code:
 
+(eval-when-compile (require 'cl))
+
 (require 'mm-util)
 
 (defvar dns-timeout 5
@@ -48,11 +50,12 @@ If nil, /etc/resolv.conf will be consulted.")
     (MR 9)
     (NULL 10)
     (WKS 11)
-    (PRT 12)
+    (PTR 12)
     (HINFO 13)
     (MINFO 14)
     (MX 15)
     (TXT 16)
+    (AAAA 28) ; RFC3596
     (AXFR 252)
     (MAILB 253)
     (MAILA 254)
@@ -249,6 +252,12 @@ If TCP-P, the first two bytes of the package with be the length field."
 	(push (list slot qs) spec)))
     (nreverse spec))))
 
+(defun dns-read-int32 ()
+  ;; Full 32 bit Integers can't be handled by Emacs.  If we use
+  ;; floats, it works.
+  (format "%.0f" (+ (* (dns-read-bytes 1) 16777216.0)
+		    (dns-read-bytes 3))))
+
 (defun dns-read-type (string type)
   (let ((buffer (current-buffer))
 	(point (point)))
@@ -262,9 +271,22 @@ If TCP-P, the first two bytes of the package with be the length field."
 	      (dotimes (i 4)
 		(push (dns-read-bytes 1) bytes))
 	      (mapconcat 'number-to-string (nreverse bytes) ".")))
-	   ((eq type 'NS)
-	    (dns-read-string-name string buffer))
-	   ((eq type 'CNAME)
+	   ((eq type 'AAAA)
+	    (let (hextets)
+	      (dotimes (i 8)
+		(push (dns-read-bytes 2) hextets))
+	      (mapconcat (lambda (n) (format "%x" n)) (nreverse hextets) ":")))
+	   ((eq type 'SOA)
+	    (list (list 'mname (dns-read-name buffer))
+		  (list 'rname (dns-read-name buffer))
+		  (list 'serial (dns-read-int32))
+		  (list 'refresh (dns-read-int32))
+		  (list 'retry (dns-read-int32))
+		  (list 'expire (dns-read-int32))
+		  (list 'minimum (dns-read-int32))))
+	   ((eq type 'MX)
+	    (cons (dns-read-bytes 2) (dns-read-name buffer)))
+	   ((or (eq type 'CNAME) (eq type 'NS) (eq type 'PTR))
 	    (dns-read-string-name string buffer))
 	   (t string)))
       (goto-char point))))
@@ -279,12 +301,16 @@ If TCP-P, the first two bytes of the package with be the length field."
       (setq dns-servers (nreverse dns-servers)))))
 
 ;;; Interface functions.
+(eval-when-compile
+  (when (featurep 'xemacs)
+    (require 'gnus-xmas)))
 
 (defmacro dns-make-network-process (server)
   (if (featurep 'xemacs)
       `(let ((coding-system-for-read 'binary)
 	     (coding-system-for-write 'binary))
-	 (open-network-stream "dns" (current-buffer) ,server "domain" 'udp))
+	 (open-network-stream "dns" (current-buffer)
+			      ,server "domain" 'udp))
     `(let ((server ,server)
 	   (coding-system-for-read 'binary)
 	   (coding-system-for-write 'binary))
@@ -296,6 +322,9 @@ If TCP-P, the first two bytes of the package with be the length field."
 	    :host server
 	    :service "domain"
 	    :type 'datagram)
+	 ;; Older versions of Emacs doesn't have
+	 ;; `make-network-process', so we fall back on opening a TCP
+	 ;; connection to the DNS server.
 	 (open-network-stream "dns" (current-buffer) server "domain")))))
 
 (defun query-dns (name &optional type fullp)
@@ -303,39 +332,46 @@ If TCP-P, the first two bytes of the package with be the length field."
 If FULLP, return the entire record returned."
   (setq type (or type 'A))
   (unless dns-servers
-    (dns-parse-resolv-conf)
-    (unless dns-servers
-      (error "No DNS server configuration found")))
-  (mm-with-unibyte-buffer
-    (let ((process (dns-make-network-process (car dns-servers)))
-	  (tcp-p (and (not (fboundp 'make-network-process))
-		      (not (featurep 'xemacs))))
-	  (step 100)
-	  (times (* dns-timeout 1000))
-	  (id (random 65000)))
-      (process-send-string
-       process
-       (dns-write `((id ,id)
-		    (opcode query)
-		    (queries ((,name (type ,type))))
-		    (recursion-desired-p t))
-		  tcp-p))
-      (while (and (zerop (buffer-size))
-		  (> times 0))
-	(accept-process-output process 0 step)
-	(decf times step))
-      (ignore-errors
-	(delete-process process))
-      (when tcp-p
-	(goto-char (point-min))
-	(delete-region (point) (+ (point) 2)))
-      (unless (zerop (buffer-size))
-	(let ((result (dns-read (buffer-string))))
-	  (if fullp
-	      result
-	    (let ((answer (car (dns-get 'answers result))))
-	      (when (eq type (dns-get 'type answer))
-		(dns-get 'data answer)))))))))
+    (dns-parse-resolv-conf))
+
+  (if (not dns-servers)
+      (message "No DNS server configuration found")
+    (mm-with-unibyte-buffer
+      (let ((process (condition-case ()
+			 (dns-make-network-process (car dns-servers))
+		       (error
+			(message "dns: Got an error while trying to talk to %s"
+				 (car dns-servers))
+			nil)))
+	    (tcp-p (and (not (fboundp 'make-network-process))
+			(not (featurep 'xemacs))))
+	    (step 100)
+	    (times (* dns-timeout 1000))
+	    (id (random 65000)))
+	(when process
+	  (process-send-string
+	   process
+	   (dns-write `((id ,id)
+			(opcode query)
+			(queries ((,name (type ,type))))
+			(recursion-desired-p t))
+		      tcp-p))
+	  (while (and (zerop (buffer-size))
+		      (> times 0))
+	    (accept-process-output process 0 step)
+	    (decf times step))
+	  (ignore-errors
+	    (delete-process process))
+	  (when tcp-p
+	    (goto-char (point-min))
+	    (delete-region (point) (+ (point) 2)))
+	  (unless (zerop (buffer-size))
+	    (let ((result (dns-read (buffer-string))))
+	      (if fullp
+		  result
+		(let ((answer (car (dns-get 'answers result))))
+		  (when (eq type (dns-get 'type answer))
+		    (dns-get 'data answer)))))))))))
 
 (provide 'dns)