--- /dev/null
+;;; dns.el --- Domain Name Service lookups
+;; Copyright (C) 2002 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 2, 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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; 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)
+ (PRT 12)
+ (HINFO 13)
+ (MINFO 14)
+ (MX 15)
+ (TXT 16)
+ (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)
+ (concat (mapconcat 'identity (nreverse name) ".") "." ended)
+ (mapconcat 'identity (nreverse name) "."))))
+
+(defun dns-write (spec)
+ "Write a DNS packet according to SPEC.
+\(dns-write '((id 2) (opcode query) (queries (("www.gnus.org")))))"
+ (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))))
+ (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-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 'NS)
+ (dns-read-string-name string buffer))
+ (t string)))
+ (goto-char point))))
+
+;;; Interface functions.
+
+(defun query-dns (name &optional type)
+ "Query a DNS server for NAME of TYPE."
+ (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))))))
+
+
+(provide 'dns)
+
+;;; dns.el ends here
(gnus-convert-image-to-gray-x-face (concat file ".gif") 3)
(delete-file (concat file ".gif"))))
-(defun gnus-respond-to-confirmation ()
- "Respond to a Gmane confirmation message."
- (interactive)
- (gnus-summary-show-article 'raw)
- (set-buffer gnus-article-buffer)
- (let ((buffer-read-only nil))
- (goto-char (point-min))
- (gnus-article-goto-header "Original-To")
- (replace-match "To:"))
- (let ((auth nil))
- (when (and (search-forward "Majordomo" nil t)
- (re-search-forward "auth.*subscribe.*$" nil t))
- (setq auth (match-string 0)))
- (message-wide-reply)
- (goto-char (point-min))
- (gnus-article-goto-header "Cc")
- (replace-match "From:")
- (message-goto-body)
- (delete-region (point) (point-max))
- (when auth
- (insert auth "\n"))))
-
-(defun gnus-subscribe-to-mailing-list (type)
- "Generate a Gmane subscription message based on the current gmane.conf line."
- (interactive
- (list
- (intern
- (completing-read "Mailing list type: "
- '(("mailman") ("majordomo") ("exmlm"))
- nil t))))
- (beginning-of-line)
- (let* ((entry
- (split-string
- (buffer-substring (point) (progn (end-of-line) (point)))
- ":"))
- (local (car (split-string (nth 2 entry) "@")))
- (host (cadr (split-string (nth 2 entry) "@")))
- (from (car entry))
- (subject "subscribe")
- to)
- (when (string-match "#" from)
- (setq from (substring from 1)))
- (cond
- ((eq type 'mailman)
- (setq to (concat local "-request@" host)))
- ((eq type 'majordomo)
- (setq to (concat "majordomo@" host)
- subject (concat "subscribe " local)))
- ((eq type 'exmlm)
- (setq to (concat local "-" from "=m.gmane.org@" host)))
- (t
- (error "No such type: %s" type)))
- (message-mail
- to subject
- `((From . ,(concat from "@m.gmane.org"))))
- (message-goto-body)
- (delete-region (point) (point-max))
- (insert subject "\n")))
-
(provide 'gnus-fun)
;;; gnus-fun.el ends here
projects / gnus / commitdiff