X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fdns.el;h=475909a70d3f17792ab8cf644e1d35b5cbb183fd;hb=2e76cef1ae7fe62bf6743fd9388339edb6e2d59b;hp=f509a215cb6dd3c5ad2f9fabc66ef9d031d0cf4f;hpb=53ab3973f51bd04a72e0948f35315cb3e7dbac9d;p=gnus

diff --git a/lisp/dns.el b/lisp/dns.el
index f509a215c..475909a70 100644
--- a/lisp/dns.el
+++ b/lisp/dns.el
@@ -25,6 +25,17 @@
 
 ;;; Code:
 
+(require 'mm-util)
+
+(defvar dns-timeout 5
+  "How many seconds to wait when doing DNS queries.")
+
+(defvar dns-servers nil
+  "Which DNS servers to query.
+If nil, /etc/resolv.conf will be consulted.")
+
+;;; Internal code:
+
 (defvar dns-query-types
   '((A 1)
     (NS 2)
@@ -114,12 +125,14 @@
 				  (progn (forward-char length) (point)))
 		name))))
     (if (stringp ended)
-	(concat (mapconcat 'identity (nreverse name) ".") "." ended)
+	(if (null name)
+	    ended
+	  (concat (mapconcat 'identity (nreverse name) ".") "." ended))
       (mapconcat 'identity (nreverse name) "."))))
 
-(defun dns-write (spec)
+(defun dns-write (spec &optional tcp-p)
   "Write a DNS packet according to SPEC.
-\(dns-write '((id 2) (opcode query) (queries (("www.gnus.org")))))"
+If TCP-P, the first two bytes of the package with be the length field."
   (with-temp-buffer
     (dns-write-bytes (dns-get 'id spec) 2)
     (dns-write-bytes
@@ -164,6 +177,9 @@
       (dns-write-bytes (dns-get 'ttl resource) 4)
       (dns-write-bytes (length (dns-get 'data resource)) 2)
       (insert (dns-get 'data resource))))
+    (when tcp-p
+      (goto-char (point-min))
+      (dns-write-bytes (buffer-size) 2))
     (buffer-string)))
 
 (defun dns-read (packet)
@@ -248,34 +264,78 @@
 	      (mapconcat 'number-to-string (nreverse bytes) ".")))
 	   ((eq type 'NS)
 	    (dns-read-string-name string buffer))
+	   ((eq type 'CNAME)
+	    (dns-read-string-name string buffer))
 	   (t string)))
       (goto-char point))))
 
+(defun dns-parse-resolv-conf ()
+  (when (file-exists-p "/etc/resolv.conf")
+    (with-temp-buffer
+      (insert-file-contents "/etc/resolv.conf")
+      (goto-char (point-min))
+      (while (re-search-forward "^nameserver[\t ]+\\([^ \t\n]+\\)" nil t)
+	(push (match-string 1) dns-servers))
+      (setq dns-servers (nreverse dns-servers)))))
+
 ;;; Interface functions.
 
-(defun query-dns (name &optional type)
-  "Query a DNS server for NAME of TYPE."
+(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))
+    `(let ((server ,server)
+	   (coding-system-for-read 'binary)
+	   (coding-system-for-write 'binary))
+       (if (fboundp 'make-network-process)
+	   (make-network-process
+	    :name "dns"
+	    :coding 'binary
+	    :buffer (current-buffer)
+	    :host server
+	    :service "domain"
+	    :type 'datagram)
+	 (open-network-stream "dns" (current-buffer) server "domain")))))
+
+(defun query-dns (name &optional type fullp)
+  "Query a DNS server for NAME of TYPE.
+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 ((coding-system-for-read 'binary)
-	  (coding-system-for-write 'binary))
-      (let ((process
-	     (make-network-process
-	      :name "dns"
-	      :coding 'binary
-	      :buffer (current-buffer)
-	      :host "ns2.netfonds.no"
-	      :service "domain"
-	      :type 'datagram)))
-	(process-send-string
-	 process
-	 (dns-write `((id 4)
-		      (opcode query)
-		      (queries ((,name)))
-		      (recursion-desired-p t))))
-	(while (zerop (buffer-size))
-	  (accept-process-output process 1))
-	(dns-read (buffer-string))))))
-    
+    (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)))))))))
 
 (provide 'dns)