Mercurial > emacs

changeset 86914:444c508e6655

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Move to ../net.
author Glenn Morris <rgm@gnu.org>
date Sat, 01 Dec 2007 20:57:35 +0000
parents 0ead56f6db1c
children b48d018b85e2
files lisp/gnus/dns.el
diffstat 1 files changed, 0 insertions(+), 426 deletions(-) [+]
line wrap: on
line diff
--- a/lisp/gnus/dns.el	Sat Dec 01 20:46:06 2007 +0000
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,426 +0,0 @@
-;;; dns.el --- Domain Name Service lookups
-
-;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
-
-;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
-;; Keywords: network
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 3, or (at your option)
-;; any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.	 See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING.  If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
-
-;;; Commentary:
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-
-(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)
-    (MD 3)
-    (MF 4)
-    (CNAME 5)
-    (SOA 6)
-    (MB 7)
-    (MG 8)
-    (MR 9)
-    (NULL 10)
-    (WKS 11)
-    (PTR 12)
-    (HINFO 13)
-    (MINFO 14)
-    (MX 15)
-    (TXT 16)
-    (AAAA 28) ; RFC3596
-    (SRV 33) ; RFC2782
-    (AXFR 252)
-    (MAILB 253)
-    (MAILA 254)
-    (* 255))
-  "Names of query types and their values.")
-
-(defvar dns-classes
-  '((IN 1)
-    (CS 2)
-    (CH 3)
-    (HS 4))
-  "Classes of queries.")
-
-(defun dns-write-bytes (value &optional length)
-  (let (bytes)
-    (dotimes (i (or length 1))
-      (push (% value 256) bytes)
-      (setq value (/ value 256)))
-    (dolist (byte bytes)
-      (insert byte))))
-
-(defun dns-read-bytes (length)
-  (let ((value 0))
-    (dotimes (i length)
-      (setq value (logior (* value 256) (following-char)))
-      (forward-char 1))
-    value))
-
-(defun dns-get (type spec)
-  (cadr (assq type spec)))
-
-(defun dns-inverse-get (value spec)
-  (let ((found nil))
-    (while (and (not found)
-		spec)
-      (if (eq value (cadr (car spec)))
-	  (setq found (caar spec))
-	(pop spec)))
-    found))
-
-(defun dns-write-name (name)
-  (dolist (part (split-string name "\\."))
-    (dns-write-bytes (length part))
-    (insert part))
-  (dns-write-bytes 0))
-
-(defun dns-read-string-name (string buffer)
-  (mm-with-unibyte-buffer
-    (insert string)
-    (goto-char (point-min))
-    (dns-read-name buffer)))
-
-(defun dns-read-name (&optional buffer)
-  (let ((ended nil)
-	(name nil)
-	length)
-    (while (not ended)
-      (setq length (dns-read-bytes 1))
-      (if (= 192 (logand length (lsh 3 6)))
-	  (let ((offset (+ (* (logand 63 length) 256)
-			   (dns-read-bytes 1))))
-	    (save-excursion
-	      (when buffer
-		(set-buffer buffer))
-	      (goto-char (1+ offset))
-	      (setq ended (dns-read-name buffer))))
-	(if (zerop length)
-	    (setq ended t)
-	  (push (buffer-substring (point)
-				  (progn (forward-char length) (point)))
-		name))))
-    (if (stringp ended)
-	(if (null name)
-	    ended
-	  (concat (mapconcat 'identity (nreverse name) ".") "." ended))
-      (mapconcat 'identity (nreverse name) "."))))
-
-(defun dns-write (spec &optional tcp-p)
-  "Write a DNS packet according to SPEC.
-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
-     (logior
-      (lsh (if (dns-get 'response-p spec) 1 0) -7)
-      (lsh
-       (cond
-	((eq (dns-get 'opcode spec) 'query) 0)
-	((eq (dns-get 'opcode spec) 'inverse-query) 1)
-	((eq (dns-get 'opcode spec) 'status) 2)
-	(t (error "No such opcode: %s" (dns-get 'opcode spec))))
-       -3)
-      (lsh (if (dns-get 'authoritative-p spec) 1 0) -2)
-      (lsh (if (dns-get 'truncated-p spec) 1 0) -1)
-      (lsh (if (dns-get 'recursion-desired-p spec) 1 0) 0)))
-    (dns-write-bytes
-     (cond 
-      ((eq (dns-get 'response-code spec) 'no-error) 0)
-      ((eq (dns-get 'response-code spec) 'format-error) 1)
-      ((eq (dns-get 'response-code spec) 'server-failure) 2)
-      ((eq (dns-get 'response-code spec) 'name-error) 3)
-      ((eq (dns-get 'response-code spec) 'not-implemented) 4)
-      ((eq (dns-get 'response-code spec) 'refused) 5)
-      (t 0)))
-    (dns-write-bytes (length (dns-get 'queries spec)) 2)
-    (dns-write-bytes (length (dns-get 'answers spec)) 2)
-    (dns-write-bytes (length (dns-get 'authorities spec)) 2)
-    (dns-write-bytes (length (dns-get 'additionals spec)) 2)
-    (dolist (query (dns-get 'queries spec))
-      (dns-write-name (car query))
-      (dns-write-bytes (cadr (assq (or (dns-get 'type query) 'A)
-				   dns-query-types)) 2)
-      (dns-write-bytes (cadr (assq (or (dns-get 'class query) 'IN)
-				   dns-classes)) 2))
-    (dolist (slot '(answers authorities additionals))
-      (dolist (resource (dns-get slot spec))
-	(dns-write-name (car resource))
-      (dns-write-bytes (cadr (assq (dns-get 'type resource) dns-query-types))
-		       2)
-      (dns-write-bytes (cadr (assq (dns-get 'class resource) dns-classes))
-		       2)
-      (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)
-  (mm-with-unibyte-buffer
-    (let ((spec nil)
-	  queries answers authorities additionals)
-      (insert packet)
-      (goto-char (point-min))
-      (push (list 'id (dns-read-bytes 2)) spec)
-      (let ((byte (dns-read-bytes 1)))
-	(push (list 'response-p (if (zerop (logand byte (lsh 1 7))) nil t))
-	      spec)
-	(let ((opcode (logand byte (lsh 7 3))))
-	  (push (list 'opcode
-		      (cond ((eq opcode 0) 'query)
-			    ((eq opcode 1) 'inverse-query)
-			    ((eq opcode 2) 'status)))
-		spec))
-	(push (list 'authoritative-p (if (zerop (logand byte (lsh 1 2)))
-					 nil t)) spec)
-	(push (list 'truncated-p (if (zerop (logand byte (lsh 1 2))) nil t))
-	      spec)
-	(push (list 'recursion-desired-p
-		    (if (zerop (logand byte (lsh 1 0))) nil t)) spec))
-      (let ((rc (logand (dns-read-bytes 1) 15)))
-	(push (list 'response-code
-		    (cond
-		     ((eq rc 0) 'no-error)
-		     ((eq rc 1) 'format-error)
-		     ((eq rc 2) 'server-failure)
-		     ((eq rc 3) 'name-error)
-		     ((eq rc 4) 'not-implemented)
-		     ((eq rc 5) 'refused)))
-	      spec))
-      (setq queries (dns-read-bytes 2))
-      (setq answers (dns-read-bytes 2))
-      (setq authorities (dns-read-bytes 2))
-      (setq additionals (dns-read-bytes 2))
-      (let ((qs nil))
-	(dotimes (i queries)
-	  (push (list (dns-read-name)
-		      (list 'type (dns-inverse-get (dns-read-bytes 2)
-						   dns-query-types))
-		      (list 'class (dns-inverse-get (dns-read-bytes 2)
-						    dns-classes)))
-		qs))
-	(push (list 'queries qs) spec))
-    (dolist (slot '(answers authorities additionals))
-      (let ((qs nil)
-	    type)
-	(dotimes (i (symbol-value slot))
-	  (push (list (dns-read-name)
-		      (list 'type
-			    (setq type (dns-inverse-get (dns-read-bytes 2)
-							dns-query-types)))
-		      (list 'class (dns-inverse-get (dns-read-bytes 2)
-						    dns-classes))
-		      (list 'ttl (dns-read-bytes 4))
-		      (let ((length (dns-read-bytes 2)))
-			(list 'data
-			      (dns-read-type
-			       (buffer-substring
-				(point)
-				(progn (forward-char length) (point)))
-			       type))))
-		qs))
-	(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)))
-    (prog1
-	(mm-with-unibyte-buffer
-	  (insert string)
-	  (goto-char (point-min))
-	  (cond
-	   ((eq type 'A)
-	    (let ((bytes nil))
-	      (dotimes (i 4)
-		(push (dns-read-bytes 1) bytes))
-	      (mapconcat 'number-to-string (nreverse bytes) ".")))
-	   ((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 'SRV)
-	    (list (list 'priority (dns-read-bytes 2))
-		  (list 'weight (dns-read-bytes 2))
-		  (list 'port (dns-read-bytes 2))
-		  (list 'target (dns-read-name buffer))))
-	   ((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))))
-
-(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)))))
-
-(defun dns-read-txt (string)
-  (if (> (length string) 1)
-      (substring string 1)
-    string))
-
-(defun dns-get-txt-answer (answers)
-  (let ((result "")
-	(do-next nil))
-    (dolist (answer answers)
-      (dolist (elem answer)
-	(when (consp elem)
-	  (cond
-	   ((eq (car elem) 'type)
-	    (setq do-next (eq (cadr elem) 'TXT)))
-	   ((eq (car elem) 'data)
-	    (when do-next
-	      (setq result (concat result (dns-read-txt (cadr elem))))))))))
-    result))
-
-;;; Interface functions.
-(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)
-	 ;; 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")))))
-
-(defvar dns-cache (make-vector 4096 0))
-
-(defun query-dns-cached (name &optional type fullp reversep)
-  (let* ((key (format "%s:%s:%s:%s" name type fullp reversep))
-	 (sym (intern-soft key dns-cache)))
-    (if (and sym
-	     (boundp sym))
-	(symbol-value sym)
-      (let ((result (query-dns name type fullp reversep)))
-	(set (intern key dns-cache) result)
-	result))))
-
-(defun query-dns (name &optional type fullp reversep)
-  "Query a DNS server for NAME of TYPE.
-If FULLP, return the entire record returned.
-If REVERSEP, look up an IP address."
-  (setq type (or type 'A))
-  (unless dns-servers
-    (dns-parse-resolv-conf))
-
-  (when reversep
-    (setq name (concat
-		(mapconcat 'identity (nreverse (split-string name "\\.")) ".")
-		".in-addr.arpa")
-	  type 'PTR))
-
-  (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))
-	    (sit-for (/ step 1000.0))
-	    (accept-process-output process 0 step)
-	    (decf times step))
-	  (ignore-errors
-	    (delete-process process))
-	  (when (and tcp-p
-		     (>= (buffer-size) 2))
-	    (goto-char (point-min))
-	    (delete-region (point) (+ (point) 2)))
-	  (when (and (>= (buffer-size) 2)
-		     ;; We had a time-out.
-		     (> times 0))
-	    (let ((result (dns-read (buffer-string))))
-	      (if fullp
-		  result
-		(let ((answer (car (dns-get 'answers result))))
-		  (when (eq type (dns-get 'type answer))
-		    (if (eq type 'TXT)
-			(dns-get-txt-answer (dns-get 'answers result))
-		      (dns-get 'data answer))))))))))))
-
-(provide 'dns)
-
-;;; arch-tag: d0edd0c4-4cce-4538-ae92-06c3356ee80a
-;;; dns.el ends here