From: ueno Date: Sun, 5 Nov 2000 05:21:38 +0000 (+0000) Subject: Synch with Gnus. X-Git-Tag: t-gnus-6_14-quimby-before-installer-changed-~15 X-Git-Url: http://git.chise.org/gitweb/?a=commitdiff_plain;h=9799858940286479df334d2d5732c79c64496a32;p=elisp%2Fgnus.git- Synch with Gnus. --- diff --git a/contrib/base64.el b/contrib/base64.el new file mode 100644 index 0000000..572a5d3 --- /dev/null +++ b/contrib/base64.el @@ -0,0 +1,278 @@ +;;; base64.el,v --- Base64 encoding functions +;; Author: Kyle E. Jones +;; Created: 1997/03/12 14:37:09 +;; Version: 1.6 +;; Keywords: extensions + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (C) 1997 Kyle E. Jones +;;; +;;; This file is not part of GNU Emacs, but the same permissions apply. +;;; +;;; 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. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(eval-when-compile (require 'cl)) + +;; For non-MULE +(if (not (fboundp 'char-int)) + (defalias 'char-int 'identity)) + +(defvar base64-alphabet + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/") + +(defvar base64-decoder-program nil + "*Non-nil value should be a string that names a MIME base64 decoder. +The program should expect to read base64 data on its standard +input and write the converted data to its standard output.") + +(defvar base64-decoder-switches nil + "*List of command line flags passed to the command named by +base64-decoder-program.") + +(defvar base64-encoder-program nil + "*Non-nil value should be a string that names a MIME base64 encoder. +The program should expect arbitrary data on its standard +input and write base64 data to its standard output.") + +(defvar base64-encoder-switches nil + "*List of command line flags passed to the command named by +base64-encoder-program.") + +(defconst base64-alphabet-decoding-alist + '( + ( ?A . 00) ( ?B . 01) ( ?C . 02) ( ?D . 03) ( ?E . 04) ( ?F . 05) + ( ?G . 06) ( ?H . 07) ( ?I . 08) ( ?J . 09) ( ?K . 10) ( ?L . 11) + ( ?M . 12) ( ?N . 13) ( ?O . 14) ( ?P . 15) ( ?Q . 16) ( ?R . 17) + ( ?S . 18) ( ?T . 19) ( ?U . 20) ( ?V . 21) ( ?W . 22) ( ?X . 23) + ( ?Y . 24) ( ?Z . 25) ( ?a . 26) ( ?b . 27) ( ?c . 28) ( ?d . 29) + ( ?e . 30) ( ?f . 31) ( ?g . 32) ( ?h . 33) ( ?i . 34) ( ?j . 35) + ( ?k . 36) ( ?l . 37) ( ?m . 38) ( ?n . 39) ( ?o . 40) ( ?p . 41) + ( ?q . 42) ( ?r . 43) ( ?s . 44) ( ?t . 45) ( ?u . 46) ( ?v . 47) + ( ?w . 48) ( ?x . 49) ( ?y . 50) ( ?z . 51) ( ?0 . 52) ( ?1 . 53) + ( ?2 . 54) ( ?3 . 55) ( ?4 . 56) ( ?5 . 57) ( ?6 . 58) ( ?7 . 59) + ( ?8 . 60) ( ?9 . 61) ( ?+ . 62) ( ?/ . 63) + )) + +(defvar base64-alphabet-decoding-vector + (let ((v (make-vector 123 nil)) + (p base64-alphabet-decoding-alist)) + (while p + (aset v (car (car p)) (cdr (car p))) + (setq p (cdr p))) + v)) + +(defvar base64-binary-coding-system 'binary) + +(defun base64-run-command-on-region (start end output-buffer command + &rest arg-list) + (let ((tempfile nil) status errstring default-process-coding-system + (coding-system-for-write base64-binary-coding-system) + (coding-system-for-read base64-binary-coding-system)) + (unwind-protect + (progn + (setq tempfile (make-temp-name "base64")) + (setq status + (apply 'call-process-region + start end command nil + (list output-buffer tempfile) + nil arg-list)) + (cond ((equal status 0) t) + ((zerop (save-excursion + (set-buffer (find-file-noselect tempfile)) + (buffer-size))) + t) + (t (save-excursion + (set-buffer (find-file-noselect tempfile)) + (setq errstring (buffer-string)) + (kill-buffer nil) + (cons status errstring))))) + (ignore-errors + (delete-file tempfile))))) + +(if (featurep 'xemacs) + (defalias 'base64-insert-char 'insert-char) + (defun base64-insert-char (char &optional count ignored buffer) + (if (or (null buffer) (eq buffer (current-buffer))) + (insert-char char count) + (with-current-buffer buffer + (insert-char char count)))) + (setq base64-binary-coding-system 'no-conversion)) + +(defun base64-decode-region (start end) + (interactive "r") + ;;(message "Decoding base64...") + (let ((work-buffer nil) + (done nil) + (counter 0) + (bits 0) + (lim 0) inputpos + (non-data-chars (concat "^=" base64-alphabet))) + (unwind-protect + (save-excursion + (setq work-buffer (generate-new-buffer " *base64-work*")) + (buffer-disable-undo work-buffer) + (if base64-decoder-program + (let* ((binary-process-output t) ; any text already has CRLFs + (status (apply 'base64-run-command-on-region + start end work-buffer + base64-decoder-program + base64-decoder-switches))) + (if (not (eq status t)) + (error "%s" (cdr status)))) + (goto-char start) + (skip-chars-forward non-data-chars end) + (while (not done) + (setq inputpos (point)) + (cond + ((> (skip-chars-forward base64-alphabet end) 0) + (setq lim (point)) + (while (< inputpos lim) + (setq bits (+ bits + (aref base64-alphabet-decoding-vector + (char-int (char-after inputpos))))) + (setq counter (1+ counter) + inputpos (1+ inputpos)) + (cond ((= counter 4) + (base64-insert-char (lsh bits -16) 1 nil work-buffer) + (base64-insert-char (logand (lsh bits -8) 255) 1 nil + work-buffer) + (base64-insert-char (logand bits 255) 1 nil + work-buffer) + (setq bits 0 counter 0)) + (t (setq bits (lsh bits 6))))))) + (cond + ((or (= (point) end) + (eq (char-after (point)) ?=)) + (if (and (= (point) end) (> counter 1)) + (message + "at least %d bits missing at end of base64 encoding" + (* (- 4 counter) 6))) + (setq done t) + (cond ((= counter 1) + (error "at least 2 bits missing at end of base64 encoding")) + ((= counter 2) + (base64-insert-char (lsh bits -10) 1 nil work-buffer)) + ((= counter 3) + (base64-insert-char (lsh bits -16) 1 nil work-buffer) + (base64-insert-char (logand (lsh bits -8) 255) + 1 nil work-buffer)) + ((= counter 0) t))) + (t (skip-chars-forward non-data-chars end))))) + (or (markerp end) (setq end (set-marker (make-marker) end))) + (goto-char start) + (insert-buffer-substring work-buffer) + (delete-region (point) end)) + (and work-buffer (kill-buffer work-buffer)))) + ;;(message "Decoding base64... done") + ) + +(defun base64-encode-region (start end &optional no-line-break) + (interactive "r") + (message "Encoding base64...") + (let ((work-buffer nil) + (counter 0) + (cols 0) + (bits 0) + (alphabet base64-alphabet) + inputpos) + (unwind-protect + (save-excursion + (setq work-buffer (generate-new-buffer " *base64-work*")) + (buffer-disable-undo work-buffer) + (if base64-encoder-program + (let ((status (apply 'base64-run-command-on-region + start end work-buffer + base64-encoder-program + base64-encoder-switches))) + (if (not (eq status t)) + (error "%s" (cdr status)))) + (setq inputpos start) + (while (< inputpos end) + (setq bits (+ bits (char-int (char-after inputpos)))) + (setq counter (1+ counter)) + (cond ((= counter 3) + (base64-insert-char (aref alphabet (lsh bits -18)) 1 nil + work-buffer) + (base64-insert-char + (aref alphabet (logand (lsh bits -12) 63)) + 1 nil work-buffer) + (base64-insert-char + (aref alphabet (logand (lsh bits -6) 63)) + 1 nil work-buffer) + (base64-insert-char + (aref alphabet (logand bits 63)) + 1 nil work-buffer) + (setq cols (+ cols 4)) + (cond ((and (= cols 72) + (not no-line-break)) + (base64-insert-char ?\n 1 nil work-buffer) + (setq cols 0))) + (setq bits 0 counter 0)) + (t (setq bits (lsh bits 8)))) + (setq inputpos (1+ inputpos))) + ;; write out any remaining bits with appropriate padding + (if (= counter 0) + nil + (setq bits (lsh bits (- 16 (* 8 counter)))) + (base64-insert-char (aref alphabet (lsh bits -18)) 1 nil + work-buffer) + (base64-insert-char (aref alphabet (logand (lsh bits -12) 63)) + 1 nil work-buffer) + (if (= counter 1) + (base64-insert-char ?= 2 nil work-buffer) + (base64-insert-char (aref alphabet (logand (lsh bits -6) 63)) + 1 nil work-buffer) + (base64-insert-char ?= 1 nil work-buffer))) + (if (and (> cols 0) + (not no-line-break)) + (base64-insert-char ?\n 1 nil work-buffer))) + (or (markerp end) (setq end (set-marker (make-marker) end))) + (goto-char start) + (insert-buffer-substring work-buffer) + (delete-region (point) end)) + (and work-buffer (kill-buffer work-buffer)))) + (message "Encoding base64... done")) + +(defun base64-encode (string &optional no-line-break) + (save-excursion + (set-buffer (get-buffer-create " *base64-encode*")) + (erase-buffer) + (insert string) + (base64-encode-region (point-min) (point-max) no-line-break) + (skip-chars-backward " \t\r\n") + (delete-region (point-max) (point)) + (prog1 + (buffer-string) + (kill-buffer (current-buffer))))) + +(defun base64-decode (string) + (save-excursion + (set-buffer (get-buffer-create " *base64-decode*")) + (erase-buffer) + (insert string) + (base64-decode-region (point-min) (point-max)) + (goto-char (point-max)) + (skip-chars-backward " \t\r\n") + (delete-region (point-max) (point)) + (prog1 + (buffer-string) + (kill-buffer (current-buffer))))) + +(defalias 'base64-decode-string 'base64-decode) +(defalias 'base64-encode-string 'base64-encode) + +(provide 'base64) diff --git a/contrib/gpg-ring.el b/contrib/gpg-ring.el new file mode 100644 index 0000000..5593b23 --- /dev/null +++ b/contrib/gpg-ring.el @@ -0,0 +1,484 @@ +;;; gpg-ring.el --- Major mode for editing GnuPG key rings. + +;; Copyright (C) 2000 RUS-CERT, University Of Stuttgart + +;; Author: Florian Weimer +;; Maintainer: Florian Weimer +;; Keywords: crypto +;; Created: 2000-04-28 + +;; $Id: gpg-ring.el,v 1.1.2.1 2000-11-05 05:21:26 ueno Exp $ + +;; This file is NOT (yet?) 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. + + + +;;;; Code: + +(require 'gpg) +(eval-when-compile + (require 'cl)) + +;;;; Customization: + +;;; Customization: Groups: + +(defgroup gpg-ring nil + "GNU Privacy Guard user interface." + :tag "GnuPG user interface" + :group 'gpg) + +;;; Customization: Variables: + +(defface gpg-ring-key-invalid-face + '((((class color)) + (:foreground "yellow" :background "red")) + (t (:bold t :italic t :underline t))) + "Face for strings indicating key invalidity." + :group 'gpg-ring) + +(defface gpg-ring-uncertain-validity-face + '((((class color)) (:foreground "red")) + (t (:bold t))) + "Face for strings indicating uncertain validity." + :group 'gpg-ring) + +(defface gpg-ring-full-validity-face + '((((class color)) (:foreground "ForestGreen" :bold t)) + (t (:bold t))) + "Face for strings indicating key invalidity." + :group 'gpg-ring) + +(defvar gpg-ring-mode-hook nil + "Normal hook run when entering GnuPG ring mode.") + +;;; Constants + +(defconst gpg-ring-algo-alist + '((rsa . "RSA") + (rsa-encrypt-only . "RSA-E") + (rsa-sign-only . "RSA-S") + (elgamal-encrypt-only . "ELG-E") + (dsa . "DSA") + (elgamal . "ELG-E")) + "Alist mapping algorithm IDs to algorithm abbreviations.") + +(defconst gpg-ring-trust-alist + '((not-known "???" gpg-ring-uncertain-validity-face) + (disabled "DIS" gpg-ring-key-invalid-face) + (revoked "REV" gpg-ring-key-invalid-face) + (expired "EXP" gpg-ring-key-invalid-face) + (trust-undefined "QES" gpg-ring-uncertain-validity-face) + (trust-none "NON" gpg-ring-uncertain-validity-face) + (trust-marginal "MAR") + (trust-full "FUL" gpg-ring-full-validity-face) + (trust-ultimate "ULT" gpg-ring-full-validity-face)) + "Alist mapping trust IDs to trust abbrevs and faces.") + +(defvar gpg-ring-mode-map + (let ((map (make-keymap))) + (suppress-keymap map t) + map) + "Keymap for `gpg-ring-mode'.") + +(define-key gpg-ring-mode-map "0" 'delete-window) +(define-key gpg-ring-mode-map "1" 'delete-other-windows) +(define-key gpg-ring-mode-map "M" 'gpg-ring-mark-process-all) +(define-key gpg-ring-mode-map "U" 'gpg-ring-unmark-all) +(define-key gpg-ring-mode-map "a" 'gpg-ring-toggle-show-unusable) +(define-key gpg-ring-mode-map "d" 'gpg-ring-mark-delete) +(define-key gpg-ring-mode-map "f" 'gpg-ring-update-key) +(define-key gpg-ring-mode-map "g" 'gpg-ring-update) +(define-key gpg-ring-mode-map "i" 'gpg-ring-show-key) +(define-key gpg-ring-mode-map "l" 'gpg-ring-toggle-show-all-ids) +(define-key gpg-ring-mode-map "m" 'gpg-ring-mark-process) +(define-key gpg-ring-mode-map "n" 'gpg-ring-next-record) +(define-key gpg-ring-mode-map "p" 'gpg-ring-previous-record) +(define-key gpg-ring-mode-map "q" 'gpg-ring-quit) +(define-key gpg-ring-mode-map "u" 'gpg-ring-unmark) +(define-key gpg-ring-mode-map "x" 'gpg-ring-extract-keys) +(define-key gpg-ring-mode-map "X" 'gpg-ring-extract-keys-to-kill) + +(define-key gpg-ring-mode-map "\C-c\C-c" 'gpg-ring-action) + +;;; Internal functions: + +(defvar gpg-ring-key-list + nil + "List of keys in the key list buffer.") +(make-variable-buffer-local 'gpg-ring-key-list) + +(defvar gpg-ring-update-funcs + nil + "List of functions called to obtain the key list.") +(make-variable-buffer-local 'gpg-ring-update-funcs) + +(defvar gpg-ring-show-unusable + nil + "If t, show expired, revoked and disabled keys, too.") +(make-variable-buffer-local 'gpg-ring-show-unusable) + +(defvar gpg-ring-show-all-ids + nil + "If t, show all user IDs. If nil, show only the primary user ID.") +(make-variable-buffer-local 'gpg-ring-show-all-ids) + +(defvar gpg-ring-marks-alist + nil + "Alist of (UNIQUE-ID MARK KEY). +UNIQUE-ID is a unique key ID from GnuPG. MARK is either `?D' +(marked for deletion), or `?*' (marked for processing).") +(make-variable-buffer-local 'gpg-ring-marks-alist) + +(defvar gpg-ring-action + nil + "Function to call when `gpg-ring-action' is invoked. +A list of the keys which are marked for processing is passed as argument.") +(make-variable-buffer-local 'gpg-ring-action) + +(defun gpg-ring-mode () + "Mode for editing GnuPG key rings. +\\{gpg-ring-mode-map} +Turning on gpg-ring-mode runs `gpg-ring-mode-hook'." + (interactive) + (kill-all-local-variables) + (buffer-disable-undo) + (setq truncate-lines t) + (setq buffer-read-only t) + (use-local-map gpg-ring-mode-map) + (setq mode-name "Key Ring") + (setq major-mode 'gpg-ring-mode) + (run-hooks 'gpg-ring-mode-hook)) + + +(defmacro gpg-ring-record-start (&optional pos) + "Return buffer position of start of record containing POS." + `(get-text-property (or ,pos (point)) 'gpg-record-start)) + +(defun gpg-ring-current-key (&optional pos) + "Return GnuPG key at POS, or at point if ommitted." + (or (get-text-property (or pos (point)) 'gpg-key) + (error "No record on current line"))) + +(defun gpg-ring-goto-record (pos) + "Go to record starting at POS. +Position point after the marks at the beginning of a record." + (goto-char pos) + (forward-char 2)) + +(defun gpg-ring-next-record () + "Advances point to the start of the next record." + (interactive) + (let ((start (next-single-property-change + (point) 'gpg-record-start nil (point-max)))) + ;; Don't advance to the last line of the buffer. + (when (/= start (point-max)) + (gpg-ring-goto-record start)))) + +(defun gpg-ring-previous-record () + "Advances point to the start of the previous record." + (interactive) + ;; The last line of the buffer doesn't contain a record. + (let ((start (gpg-ring-record-start))) + (if start + (gpg-ring-goto-record (previous-single-property-change + start 'gpg-record-start nil (point-min))) + (gpg-ring-goto-record + (gpg-ring-record-start (1- (point-max))))))) + +(defun gpg-ring-set-mark (&optional pos mark) + "Set MARK on record at POS, or at point if POS is omitted. +If MARK is omitted, clear it." + (save-excursion + (let* ((start (gpg-ring-record-start pos)) + (key (gpg-ring-current-key start)) + (id (gpg-key-unique-id key)) + (entry (assoc id gpg-ring-marks-alist)) + buffer-read-only) + (goto-char start) + ;; Replace the mark character. + (subst-char-in-region (point) (1+ (point)) (char-after) + (or mark ? )) + ;; Store the mark in alist. + (if entry + (setcdr entry (if mark (list mark key))) + (when mark + (push (list id mark key) gpg-ring-marks-alist)))))) + +(defun gpg-ring-marked-keys (&optional only-marked mark) + "Return list of key specs which have MARK. +If no marks are present and ONLY-MARKED is not nil, return singleton +list with key of the current record. If MARK is omitted, `?*' is +used." + (let ((the-marker (or mark ?*)) + (marks gpg-ring-marks-alist) + key-list) + (while marks + (let ((mark (pop marks))) + ;; If this entry has got the right mark ... + (when (equal (nth 1 mark) the-marker) + ;; ... rember the key spec. + (push (nth 2 mark) key-list)))) + (or key-list (if (not only-marked) (list (gpg-ring-current-key)))))) + +(defun gpg-ring-mark-process () + "Mark record at point for processing." + (interactive) + (gpg-ring-set-mark nil ?*) + (gpg-ring-next-record)) + +(defun gpg-ring-mark-delete () + "Mark record at point for processing." + (interactive) + (gpg-ring-set-mark nil ?D) + (gpg-ring-next-record)) + +(defun gpg-ring-unmark () + "Mark record at point for processing." + (interactive) + (gpg-ring-set-mark) + (gpg-ring-next-record)) + +(defun gpg-ring-mark-process-all () + "Put process mark on all records." + (interactive) + (setq gpg-ring-marks-alist + (mapcar (lambda (key) + (list (gpg-key-unique-id key) ?* key)) + gpg-ring-key-list)) + (gpg-ring-regenerate)) + +(defun gpg-ring-unmark-all () + "Remove all record marks." + (interactive) + (setq gpg-ring-marks-alist nil) + (gpg-ring-regenerate)) + +(defun gpg-ring-toggle-show-unusable () + "Toggle value if `gpg-ring-show-unusable'." + (interactive) + (setq gpg-ring-show-unusable (not gpg-ring-show-unusable)) + (gpg-ring-regenerate)) + +(defun gpg-ring-toggle-show-all-ids () + "Toggle value of `gpg-ring-show-all-ids'." + (interactive) + (setq gpg-ring-show-all-ids (not gpg-ring-show-all-ids)) + (gpg-ring-regenerate)) + +(defvar gpg-ring-output-buffer-name "*GnuPG Output*" + "Name buffer to which output from GnuPG is sent.") + +(defmacro gpg-ring-with-output-buffer (&rest body) + "Erase GnuPG output buffer, evaluate BODY in it, and display it." + `(with-current-buffer (get-buffer-create gpg-ring-output-buffer-name) + (erase-buffer) + (setq truncate-lines t) + ,@body + (goto-char (point-min)) + (display-buffer gpg-ring-output-buffer-name))) + +(defun gpg-ring-quit () + "Bury key list buffer and kill GnuPG output buffer." + (interactive) + (let ((output (get-buffer gpg-ring-output-buffer-name))) + (when output + (kill-buffer output))) + (when (eq 'gpg-ring-mode major-mode) + (bury-buffer))) + +(defun gpg-ring-show-key () + "Show information for current key." + (interactive) + (let ((keys (gpg-ring-marked-keys))) + (gpg-ring-with-output-buffer + (gpg-key-insert-information (gpg-key-unique-id-list keys))))) + +(defun gpg-ring-extract-keys () + "Export currently selected public keys in ASCII armor." + (interactive) + (let ((keys (gpg-ring-marked-keys))) + (gpg-ring-with-output-buffer + (gpg-key-insert-public-key (gpg-key-unique-id-list keys))))) + +(defun gpg-ring-extract-keys-to-kill () + "Export currently selected public keys in ASCII armor to kill ring." + (interactive) + (let ((keys (gpg-ring-marked-keys))) + (with-temp-buffer + (gpg-key-insert-public-key (gpg-key-unique-id-list keys)) + (copy-region-as-kill (point-min) (point-max))))) + +(defun gpg-ring-update-key () + "Fetch key information from key server." + (interactive) + (let ((keys (gpg-ring-marked-keys))) + (gpg-ring-with-output-buffer + (gpg-key-retrieve (gpg-key-unique-id-list keys))))) + +(defun gpg-ring-insert-key-stat (key) + (let* ((validity (gpg-key-validity key)) + (validity-entry (assq validity gpg-ring-trust-alist)) + (trust (gpg-key-trust key)) + (trust-entry (assq trust gpg-ring-trust-alist))) + ;; Insert abbrev for key status. + (let ((start (point))) + (insert (nth 1 validity-entry)) + ;; Change face if necessary. + (when (nth 2 validity-entry) + (add-text-properties start (point) + (list 'face (nth 2 validity-entry))))) + ;; Trust, key ID, length, algorithm, creation date. + (insert (format "/%s %-8s/%4d/%-5s created %s" + (nth 1 trust-entry) + (gpg-short-key-id key) + (gpg-key-length key) + (cdr (assq (gpg-key-algorithm key) gpg-ring-algo-alist)) + (gpg-key-creation-date key))) + ;; Expire date. + (when (gpg-key-expire-date key) + (insert ", ") + (let ((start (point)) + (expired (eq 'expired validity)) + (notice (concat ))) + (insert (if expired "EXPIRED" "expires") + " " (gpg-key-expire-date key)) + (when expired + (add-text-properties start (point) + '(face gpg-ring-key-invalid-face))))))) + +(defun gpg-ring-insert-key (key &optional mark) + "Inserts description for KEY into current buffer before point." + (let ((start (point))) + (insert (if mark mark " ") + " " (gpg-key-primary-user-id key) "\n" + " ") + (gpg-ring-insert-key-stat key) + (insert "\n") + (when gpg-ring-show-all-ids + (let ((uids (gpg-key-user-ids key))) + (while uids + (insert " ID " (pop uids) "\n")))) + (add-text-properties start (point) + (list 'gpg-record-start start + 'gpg-key key)))) + +(defun gpg-ring-regenerate () + "Regenerate the key list buffer from stored data." + (interactive) + (let* ((key-list gpg-ring-key-list) + ;; Record position of point. + (old-record (if (eobp) ; No record on last line. + nil + (gpg-key-unique-id (gpg-ring-current-key)))) + (old-pos (if old-record (- (point) (gpg-ring-record-start)))) + found new-pos new-pos-offset buffer-read-only new-marks) + ;; Replace buffer contents with new data. + (erase-buffer) + (while key-list + (let* ((key (pop key-list)) + (id (gpg-key-unique-id key)) + (mark (assoc id gpg-ring-marks-alist))) + (when (or gpg-ring-show-unusable + (not (memq (gpg-key-validity key) + '(disabled revoked expired)))) + ;; Check if point was in this record. + (when (and old-record + (string-equal old-record id)) + (setq new-pos (point)) + (setq new-pos-offset (+ new-pos old-pos))) + ;; Check if this record was marked. + (if (nth 1 mark) + (progn + (push mark new-marks) + (gpg-ring-insert-key key (nth 1 mark))) + (gpg-ring-insert-key key))))) + ;; Replace mark alist with the new one (which does not contain + ;; marks for records which vanished during this update). + (setq gpg-ring-marks-alist new-marks) + ;; Restore point. + (if (not old-record) + ;; We were at the end of the buffer before. + (goto-char (point-max)) + (if new-pos + (if (and (< new-pos-offset (point-max)) + (equal old-record (gpg-key-unique-id + (gpg-ring-current-key new-pos-offset)))) + ;; Record is there, with offset. + (goto-char new-pos-offset) + ;; Record is there, but not offset. + (goto-char new-pos)) + ;; Record is not there. + (goto-char (point-min)))))) + +(defun gpg-ring-update () + "Update the key list buffer with new data." + (interactive) + (let ((funcs gpg-ring-update-funcs) + old) + ;; Merge the sorted lists obtained by calling elements of + ;; `gpg-ring-update-funcs'. + (while funcs + (let ((additional (funcall (pop funcs))) + new) + (while (and additional old) + (if (gpg-key-lessp (car additional) (car old)) + (push (pop additional) new) + (if (gpg-key-lessp (car old) (car additional)) + (push (pop old) new) + ;; Keys are perhaps equal. Always Add old key. + (push (pop old) new) + ;; If new key is equal, drop it, otherwise add it as well. + (if (string-equal (gpg-key-unique-id (car old)) + (gpg-key-unique-id (car additional))) + (pop additional) + (push (pop additional) new))))) + ;; Store new list as old one for next round. + (setq old (nconc (nreverse new) old additional)))) + ;; Store the list in the buffer. + (setq gpg-ring-key-list old)) + (gpg-ring-regenerate)) + +(defun gpg-ring-action () + "Perform the action associated with this buffer." + (interactive) + (if gpg-ring-action + (funcall gpg-ring-action (gpg-ring-marked-keys)) + (error "No action for this buffer specified"))) + +;;;###autoload +(defun gpg-ring-keys (&optional key-list-funcs action) + (interactive) + (let ((buffer (get-buffer-create "*GnuPG Key List*"))) + (with-current-buffer buffer + (gpg-ring-mode) + (setq gpg-ring-action action) + (setq gpg-ring-update-funcs key-list-funcs key-list-funcs) + (gpg-ring-update) + (goto-char (point-min))) + (switch-to-buffer buffer))) + +;;;###autoload +(defun gpg-ring-public (key-spec) + "List public keys matching keys KEY-SPEC." + (interactive "sList public keys containing: ") + (gpg-ring-keys `((lambda () (gpg-key-list-keys ,key-spec))))) + +(provide 'gpg-ring) + +;;; gpg-ring.el ends here \ No newline at end of file diff --git a/contrib/gpg.el b/contrib/gpg.el new file mode 100644 index 0000000..07395e6 --- /dev/null +++ b/contrib/gpg.el @@ -0,0 +1,1237 @@ +;;; gpg.el --- Interface to GNU Privacy Guard + +;; Copyright (C) 2000 RUS-CERT, University Of Stuttgart + +;; Author: Florian Weimer +;; Maintainer: Florian Weimer +;; Keywords: crypto +;; Created: 2000-04-15 + +;; $Id: gpg.el,v 1.1.2.1 2000-11-05 05:21:26 ueno Exp $ + +;; This file is NOT (yet?) 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: + +;; ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA +;; ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA +;; +;; This code is not well-tested. BE CAREFUL! +;; +;; ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA +;; ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA + +;; Implemented features which can be tested: +;; +;; * Customization for all flavors of PGP is possible. +;; * The main operations (verify, decrypt, sign, encrypt, sign & +;; encrypt) are implemented. +;; * Gero Treuner's gpg-2comp script is supported, and data which is is +;; compatible with PGP 2.6.3 is generated. + +;; Customizing external programs +;; ============================= + +;; The customization are very similar to those of others programs, +;; only the C-ish "%" constructs have been replaced by more Lisp-like +;; syntax. +;; +;; First, you have to adjust the default executable paths +;; (`gpg-command-default-alist', customization group `gpg-options', +;; "Controlling GnuPG invocation."). After that, you should +;; change the configuration options which control how specific +;; command line flags are built (`gpg-command-flag-sign-with-key', +;; (`gpg-command-flag-recipient'). The elements of these lists are +;; concatenated without spaces, and a new argument is only started +;; where indicated. The `gpg-command-flag-recipient' list is special: +;; it consists of two parts, the first one remains at the beginning +;; of the argument, the second one is repeated for each recipient. +;; Finally, `gpg-command-passphrase-env' has to be changed if there's +;; no command line flag to force the external program to read the data +;; from standard input before the message. +;; +;; In customization group `gpg-commands', "Controlling GnuPG +;; invocation.", you have to supply the actual syntax for external +;; program calls. Each variable consists of a pair of a program +;; specification (if a Lisp symbol is given here, it is translated +;; via `gpg-command-default-alist') and a list of program arguments +;; with placeholders. Please read the documentation of each variable +;; before making your adjustments and try to match the given +;; requirements as closely as possible! +;; +;; The `gpg-commands-key' group, "GnuPG Key Management Commands.", +;; specifies key management commands. The syntax of these variables +;; is like those in the `gpg-commands' group. Note that the output +;; format of some of these external programs has to match very close +;; that of GnuPG. Additional tools (Thomas Roessler's "pgpring.c") +;; are available if your favorite implementation of OpenPGP cannot +;; output the this format. + +;; Security considerations +;; ======================= + +;; On a typical multiuser UNIX system, the memory image of the +;; Emacs process is not locked, therefore it can be swapped to disk +;; at any time. As a result, the passphrase might show up in the +;; swap space (even if you don't use the passphrase cache, i.e. if +;; `gpg-passphrase-timeout' is 0). If someone is able to run `gdb' or +;; another debugger on your Emacs process, he might be able to recover +;; the passphrase as well. Unfortunately, nothing can be done in +;; order to prevent this at the moment. +;; +;; BE CAREFUL: If you use the passphrase cache feature, the passphrase +;; is stored in the variable `gpg-passphrase' -- and it is NOT +;; encrypted in any way. (This is a conceptual problem because the +;; nature of the passphrase cache requires that Emacs is able to +;; decrypt automatically, so only a very weak protection could be +;; applied anyway.) +;; +;; In addition, if you use an unpatched Emacs 20 (and earlier +;; versions), passwords show up in the output of the `view-lossage' +;; function (bound to `C-h l' by default). + + +;;;; Code: + +(require 'timer) +(eval-when-compile + (require 'cl)) + +;;;; Customization: + +;;; Customization: Groups: + +(defgroup gpg nil + "GNU Privacy Guard interface." + :tag "GnuPG" + :group 'processes) + +(defgroup gpg-options nil + "Controlling GnuPG invocation." + :tag "GnuPG Options" + :group 'gpg) + +(defgroup gpg-commands nil + "Primary GnuPG Operations." + :tag "GnuPG Commands" + :group 'gpg) + +(defgroup gpg-commands-key nil + "Commands for GnuPG key management." + :tag "GnuPG Key Commands" + :group 'gpg-commands) + +;;; Customization: Widgets: + +(define-widget 'gpg-command-alist 'alist + "An association list for GnuPG command names." + :key-type '(symbol :tag "Abbreviation") + :value-type '(string :tag "Program name") + :convert-widget 'widget-alist-convert-widget + :tag "Alist") + +(define-widget 'gpg-command-program 'choice + "Widget for entering the name of a program (mostly the GnuPG binary)." + :tag "Program" + :args '((const :tag "Default GnuPG program." + :value gpg) + (const :tag "GnuPG compatibility wrapper." + :value gpg-2comp) + (const :tag "Disabled" + :value nil) + (string :tag "Custom program" :format "%v"))) + +(define-widget 'gpg-command-sign-options 'cons + "Widget for entering signing options." + :args '(gpg-command-program + (repeat + :tag "Arguments" + (choice + :format "%[Type%] %v" + (const :tag "Insert armor option here if necessary." + :value armor) + (const :tag "Insert text mode option here if necessary." + :value textmode) + (const :tag "Insert the sign with key option here if necessary." + :value sign-with-key) + (string :format "%v"))))) + +(define-widget 'gpg-command-key-options 'cons + "Widget for entering key command options." + :args '(gpg-command-program + (repeat + :tag "Arguments" + (choice + :format "%[Type%] %v" + (const :tag "Insert key ID here." + :value key-id) + (string :format "%v"))))) + +;;; Customization: Variables: + +;;; Customization: Variables: Paths and Flags: + +(defcustom gpg-passphrase-timeout + 0 + "Timeout (in seconds) for the passphrase cache. +The passphrase cache is cleared after is hasn't been used for this +many seconds. The values 0 means that the passphrase is not cached at +all." + :tag "Passphrase Timeout" + :type 'number + :group 'gpg-options) + +(defcustom gpg-default-key-id + nil + "Default key/user ID used for signatures." + :tag "Default Key ID" + :type '(choice + (const :tag "Use GnuPG default." :value nil) + (string)) + :group 'gpg-options) + +(defcustom gpg-temp-directory + (expand-file-name "~/tmp") + "Directory for temporary files. +If you are running Emacs 20, this directory must have mode 0700." + :tag "Temp directory" + :type 'string + :group 'gpg-options) + +(defcustom gpg-command-default-alist + '((gpg . "gpg") + (gpg-2comp . "gpg-2comp")) + "Default paths for some GnuPG-related programs. +Modify this variable if you have to change the paths to the +executables required by the GnuPG interface. You can enter \"gpg\" +for `gpg-2comp' if you don't have this script, but you'll lose PGP +2.6.x compatibility." + :tag "GnuPG programs" + :type 'gpg-command-alist + :group 'gpg-options) + +(defcustom gpg-command-flag-textmode "--textmode" + "The flag to indicate canonical text mode to GnuPG." + :tag "Text mode flag" + :type 'string + :group 'gpg-options) + +(defcustom gpg-command-flag-armor "--armor" + "The flag to request ASCII-armoring output from GnuPG." + :tag "Armor flag" + :type 'string + :group 'gpg-options) + +(defcustom gpg-command-flag-sign-with-key '("--local-user=" sign-with-key) + "String to include to specify the signing key ID. +The elements are concatenated (without spaces) to form a command line +option." + :tag "Sign with key flag" + :type '(repeat :tag "Argument parts" + (choice :format "%[Type%] %v" + (const :tag "Start next argument." :value next-argument) + (const :tag "Insert signing key ID here." :value sign-with-key) + (string))) + :group 'gpg-options) + +(defcustom gpg-command-flag-recipient + '(nil . ("-r" next-argument recipient next-argument)) + "Format of a recipient specification. +The elements are concatenated (without spaces) to form a command line +option. The second part is repeated for each recipient." + :tag "Recipients Flag" + :type '(cons + (repeat :tag "Common prefix" + (choice :format "%[Type%] %v" + (const :tag "Start next argument." :value next-argument) + (string))) + (repeat :tag "For each recipient" + (choice :format "%[Type%] %v" + (const :tag "Start next argument." :value next-argument) + (const :tag "Insert recipient key ID here." :value recipient) + (string)))) + :group 'gpg-options) + +(defcustom gpg-command-passphrase-env + nil + "Environment variable to set when a passphrase is required, or nil. +If an operation is invoked which requires a passphrase, this +environment variable is set before calling the external program to +indicate that it should read the passphrase from standard input." + :tag "Passphrase environment" + :type '(choice + (const :tag "Disabled" :value nil) + (cons + (string :tag "Variable") + (string :tag "Value"))) + :group 'gpg-options) + +;;; Customization: Variables: GnuPG Commands: + +(defcustom gpg-command-verify + '(gpg . ("--batch" "--verbose" "--verify" signature-file message-file)) + "Command to verify a detached signature. +The invoked program has to read the signed message and the signature +from the given files. It should write human-readable information to +standard output and/or standard error. The program shall not convert +charsets or line endings; the input data shall be treated as binary." + :tag "Verify Command" + :type '(cons + gpg-command-program + (repeat + :tag "Arguments" + (choice + :format "%[Type%] %v" + (const :tag "Insert name of file containing the message here." + :value message-file) + (const :tag "Insert name of file containing the signature here." + :value signature-file) + (string :format "%v")))) + :group 'gpg-commands) + +(defcustom gpg-command-decrypt + '(gpg . ("--decrypt" "--batch" "--passphrase-fd=0")) + "Command to decrypt a message. +The invoked program has to read the passphrase from standard +input, followed by the encrypted message. It writes the decrypted +message to standard output, and human-readable diagnostic messages to +standard error." + :tag "Decrypt Command" + :type '(cons + gpg-command-program + (repeat + :tag "Arguments" + (choice + :format "%[Type%] %v" + (const :tag "Insert name of file containing the message here." + :value message-file) + (string :format "%v")))) + :group 'gpg-commands) + +(defcustom gpg-command-sign-cleartext + '(gpg-2comp . ("--batch" "--passphrase-fd=0" "--output=-" + armor textmode "--clearsign" + sign-with-key)) + "Command to create a create a \"clearsign\" text file. +The invoked program has to read the passphrase from standard input, +followed by the message to sign. It should write the ASCII-amored +signed text message to standard output, and diagnostic messages to +standard error." + :tag "Clearsign Command" + :type 'gpg-command-sign-options + :group 'gpg-commands) + +(defcustom gpg-command-sign-detached + '(gpg-2comp . ("--batch" "--passphrase-fd=0" "--output=-" + armor textmode "--detach-sign" + sign-with-key)) + "Command to create a create a detached signature. +The invoked program has to read the passphrase from standard input, +followed by the message to sign. It should write the ASCII-amored +detached signature to standard output, and diagnostic messages to +standard error. The program shall not convert charsets or line +endings; the input data shall be treated as binary." + :tag "Sign Detached Command" + :type 'gpg-command-sign-options + :group 'gpg-commands) + +(defcustom gpg-command-sign-encrypt + '(gpg-2comp . ("--batch" "--passphrase-fd=0" "--output=-" + armor textmode "--always-trust" sign-with-key recipients + "--sign" "--encrypt" plaintext-file)) + "Command to sign and encrypt a file. +The invoked program has to read the passphrase from standard input, +followed by the message to sign and encrypt if there is no +`plaintext-file' placeholder. It should write the ASCII-amored +encrypted message to standard output, and diagnostic messages to +standard error." + :tag "Sign And Encrypt Command" + :type '(cons + gpg-command-program + (repeat + :tag "Arguments" + (choice + :format "%[Type%] %v" + (const :tag "Insert the `sign with key' option here if necessary." + :value sign-with-key) + (const :tag "Insert list of recipients here." + :value recipients) + (const :tag "Insert here name of file with plaintext." + :value plaintext-file) + (string :format "%v")))) + :group 'gpg-commands) + +(defcustom gpg-command-encrypt + '(gpg-2comp . ("--batch" "--output=-" armor textmode "--always-trust" + "--encrypt" recipients plaintext-file)) + "Command to encrypt a file. +The invoked program has to read the message to encrypt from standard +input or from the plaintext file (if the `plaintext-file' placeholder +is present). It should write the ASCII-amored encrypted message to +standard output, and diagnostic messages to standard error." + :type '(cons + gpg-command-program + (repeat + :tag "Arguments" + (choice + :format "%[Type%] %v" + (const :tag "Insert list of recipients here." + :value recipients) + (const :tag "Insert here name of file with plaintext." + :value plaintext-file) + (string :format "%v")))) + :group 'gpg-commands) + +;;; Customization: Variables: Key Management Commands: + +(defcustom gpg-command-key-import + '(gpg . ("--import" "--verbose" message-file)) + "Command to import a public key from a file." + :tag "Import Command" + :type '(cons + gpg-command-program + (repeat + :tag "Arguments" + (choice + :format "%[Type%] %v" + (const :tag "Insert name of file containing the key here." + :value message-file) + (string :format "%v")))) + :group 'gpg-commands-key) + +(defcustom gpg-command-key-export + '(gpg . ("--no-verbose" "--armor" "--export" key-id)) + "Command to export a public key from the key ring. +The key should be written to standard output using ASCII armor." + :tag "Export Command" + :type 'gpg-command-key-options + :group 'gpg-commands-key) + +(defcustom gpg-command-key-verify + '(gpg . ("--no-verbose" "--batch" "--fingerprint" "--check-sigs" key-id)) + "Command to verify a public key." + :tag "Verification Command" + :type 'gpg-command-key-options + :group 'gpg-commands-key) + +(defcustom gpg-command-key-public-ring + '(gpg . ("--no-verbose" "--batch" "--with-colons" "--list-keys" key-id)) + "Command to list the contents of the public key ring." + :tag "List Public Key Ring Command" + :type 'gpg-command-key-options + :group 'gpg-commands-key) + +(defcustom gpg-command-key-secret-ring + '(gpg . ("--no-verbose" "--batch" "--with-colons" + "--list-secret-keys" key-id)) + "Command to list the contents of the secret key ring." + :tag "List Secret Key Ring Command" + :type 'gpg-command-key-options + :group 'gpg-commands-key) + +(defcustom gpg-command-key-retrieve + '(gpg . ("--batch" "--recv-keys" key-id)) + "Command to retrieve public keys." + :tag "Retrieve Keys Command" + :type 'gpg-command-key-options + :group 'gpg-commands-key) + + +;;;; Helper functions for GnuPG invocation: + +;;; Build the GnuPG command line: + +(defun gpg-build-argument (template substitutions &optional pass-start) + "Build command line argument(s) by substituting placeholders. +TEMPLATE is a list of strings and symbols. The placeholder symbols in +it are replaced by SUBSTITUTIONS, the elements between +`next-argument' symbols are concatenated without spaces and are +returned in a list. + +SUBSTITIONS is a list of (SYMBOL . SEXP) pairs, where SEXP is either +a string (which is inserted literally), a list of strings (which are +inserted as well), or nil, which means to insert nothing. + +If PASS-START is t, `next-argument' is also inserted into the result, +and symbols without a proper substitution are retained in the output, +otherwise, an untranslated symbol results in an error. + +This function does not handle empty arguments reliably." + (let ((current-arg "") + (arglist nil)) + (while template + (let* ((templ (pop template)) + (repl (assoc templ substitutions)) + (new (if repl (cdr repl) templ))) + (cond + ((eq templ 'next-argument) + ;; If the current argument is not empty, start a new one. + (unless (equal current-arg "") + (setq arglist (nconc arglist + (if pass-start + (list current-arg 'next-argument) + (list current-arg)))) + (setq current-arg ""))) + ((null new) nil) ; Drop it. + ((and (not (stringp templ)) (null repl)) + ;; Retain an untranslated symbol in the output if + ;; `pass-start' is true. + (unless pass-start + (error "No replacement for `%s'" templ)) + (setq arglist (nconc arglist (list current-arg templ))) + (setq current-arg "")) + (t + (unless (listp new) + (setq new (list new))) + (setq current-arg (concat current-arg + (apply 'concat new))))))) + (unless (equal current-arg "") + (setq arglist (nconc arglist (list current-arg)))) + arglist)) + +(defun gpg-build-arg-list (template substitutions) + "Build command line by substituting placeholders. +TEMPLATE is a list of strings and symbols. The placeholder symbols in +it are replaced by SUBSTITUTIONS. + +SUBSTITIONS is a list of (SYMBOL . SEXP) pairs, where SEXP is either a +string (which is inserted literally), a list of strings (which are +inserted as well), or nil, which means to insert nothing." + (let (arglist) + (while template + (let* ((templ (pop template)) + (repl (assoc templ substitutions)) + (new (if repl (cdr repl) templ))) + (cond + ((and (symbolp templ) (null repl)) + (error "No replacement for `%s'" templ)) + ((null new) nil) ; Drop it. + (t + (unless (listp new) + (setq new (list new))) + (setq arglist (nconc arglist new)))))) + arglist)) + +(defun gpg-build-flag-recipients-one (recipient) + "Build argument for one RECIPIENT." + (gpg-build-argument (cdr gpg-command-flag-recipient) + `((recipient . ,recipient)) t)) + +(defun gpg-build-flag-recipients (recipients) + "Build list of RECIPIENTS using `gpg-command-flag-recipient'." + (gpg-build-argument + (apply 'append (car gpg-command-flag-recipient) + (mapcar 'gpg-build-flag-recipients-one + recipients)) + nil)) + +(defun gpg-read-recipients () + "Query the user for several recipients." + (let ((go t) + recipients r) + (while go + (setq r (read-string "Enter recipient ID [RET when no more]: ")) + (if (equal r "") + (setq go nil) + (setq recipients (nconc recipients (list r))))) + recipients)) + +(defun gpg-build-flag-sign-with-key (key) + "Build sign with key flag using `gpg-command-flag-sign-with-key'." + (let ((k (if key key + (if gpg-default-key-id gpg-default-key-id + nil)))) + (if k + (gpg-build-argument gpg-command-flag-sign-with-key + (list (cons 'sign-with-key k))) + nil))) + +(defmacro gpg-with-passphrase-env (&rest body) + "Adjust the process environment and evaluate BODY. +During the evaluation of the body forms, the process environment is +adjust according to `gpg-command-passphrase-env'." + (let ((env-value (make-symbol "env-value"))) + `(let ((,env-value)) + (unwind-protect + (progn + (when gpg-command-passphrase-env + (setq ,env-value (getenv (car gpg-command-passphrase-env))) + (setenv (car gpg-command-passphrase-env) + (cdr gpg-command-passphrase-env))) + ,@body) + (when gpg-command-passphrase-env + ;; This will clear the variable if it wasn't set before. + (setenv (car gpg-command-passphrase-env) ,env-value)))))) + +;;; Temporary files: + +(defun gpg-make-temp-file () + "Create a temporary file in a safe way" + (let ((name (concat gpg-temp-directory "/gnupg"))) + (if (fboundp 'make-temp-file) + ;; If we've got make-temp-file, we are on the save side. + (make-temp-file name) + ;; make-temp-name doesn't create the file, and an ordinary + ;; write-file operation is prone to nasty symlink attacks if the + ;; temporary file resides in a world-writable directory. + (unless (eq (file-modes gpg-temp-directory) 448) ; mode 0700 + (error "Directory for temporary files must have mode 0700.")) + (setq name (make-temp-name name)) + (let ((mode (default-file-modes))) + (unwind-protect + (progn + (set-default-file-modes 384) ; mode 0600 + (with-temp-file name)) + (set-default-file-modes mode))) + name))) + +(defvar gpg-temp-files nil + "List of temporary files used by the GnuPG interface. +Do not set this variable. Call `gpg-with-temp-files' if you need +temporary files.") + +(defun gpg-with-temp-files-create (count) + "Do not call this function. Used internally by `gpg-with-temp-files'." + (while (> count 0) + (setq gpg-temp-files (cons (gpg-make-temp-file) gpg-temp-files)) + (setq count (1- count)))) + +(defun gpg-with-temp-files-delete () + "Do not call this function. Used internally by `gpg-with-temp-files'." + (while gpg-temp-files + (let ((file (pop gpg-temp-files))) + (condition-case nil + (delete-file file) + (error nil))))) + +(defmacro gpg-with-temp-files (count &rest body) + "Create COUNT temporary files, USE them, and delete them. +The function USE is called with the names of all temporary files as +arguments." + `(let ((gpg-temp-files)) + (unwind-protect + (progn + ;; Create the temporary files. + (gpg-with-temp-files-create ,count) + ,@body) + (gpg-with-temp-files-delete)))) + +;;; Making subprocesses: + +(defun gpg-exec-path (option) + "Return the program name for OPTION. +OPTION is of the form (PROGRAM . ARGLIST). This functions returns +PROGRAM, but takes default values into account." + (let* ((prg (car option)) + (path (assq prg gpg-command-default-alist))) + (cond + (path (if (null (cdr path)) + (error "Command `%s' is not available" prg) + (cdr path))) + ((null prg) (error "Command is disabled")) + (t prg)))) + +(defun gpg-call-process (cmd args stdin stdout stderr &optional passphrase) + "Invoke external program CMD with ARGS on buffer STDIN. +Standard output is insert before point in STDOUT, standard error in +STDERR. If PASSPHRASE is given, send it before STDIN. PASSPHRASE +should not end with a line feed (\"\\n\"). + +If `stdin-file' is present in ARGS, it is replaced by the name of a +temporary file. Before invoking CMD, the contents of STDIN is written +to this file." + (gpg-with-temp-files 2 + (let* ((coding-system-for-read 'no-conversion) + (coding-system-for-write 'no-conversion) + (have-stdin-file (memq 'stdin-file args)) + (stdin-file (nth 0 gpg-temp-files)) + (stderr-file (nth 1 gpg-temp-files)) + (cpr-args `(,cmd + nil ; don't delete + (,stdout ,stderr-file) + nil ; don't display + ;; Replace `stdin-file'. + ,@(gpg-build-arg-list + args (list (cons 'stdin-file stdin-file))))) + res) + (when have-stdin-file + (with-temp-file stdin-file + (buffer-disable-undo) + (insert-buffer-substring stdin))) + (setq res + (if passphrase + (with-temp-buffer + (buffer-disable-undo) + (insert passphrase "\n") + (unless have-stdin-file + (apply 'insert-buffer-substring + (if (listp stdin) stdin (list stdin)))) + (apply 'call-process-region (point-min) (point-max) cpr-args) + ;; Wipe out passphrase. + (goto-char (point-min)) + (translate-region (point) (line-end-position) + (make-string 256 ? ))) + (if (listp stdin) + (with-current-buffer (car stdin) + (apply 'call-process-region + (cadr stdin) + (if have-stdin-file (cadr stdin) (caddr stdin)) + cpr-args)) + (with-current-buffer stdin + (apply 'call-process-region + (point-min) + (if have-stdin-file (point-min) (point-max)) + cpr-args))))) + (with-current-buffer stderr + (insert-file-contents-literally stderr-file)) + (if (or (stringp res) (> res 0)) + ;; Signal or abnormal exit. + (with-current-buffer stderr + (goto-char (point-max)) + (insert (format "\nCommand exit status: %s\n" res)) + nil) + t)))) + +(defvar gpg-result-buffer nil + "The result of a GnuPG operation is stored in this buffer. +Never set this variable directly, use `gpg-show-result' instead.") + +(defun gpg-show-result-buffer (always-show result) + "Called by `gpg-show-results' to actually show the buffer." + (with-current-buffer gpg-result-buffer + ;; Only proceed if the buffer is non-empty. + (when (and (/= (point-min) (point-max)) + (or always-show (not result))) + (save-window-excursion + (display-buffer (current-buffer)) + (unless (y-or-n-p "Continue? ") + (error "GnuPG operation aborted.")))))) + +(defmacro gpg-show-result (always-show &rest body) + "Show GnuPG result to user for confirmation. +This macro binds `gpg-result-buffer' to a temporary buffer and +evaluates BODY, like `progn'. If BODY evaluates to `nil' (or +`always-show' is not nil), the user is asked for confirmation." + `(let ((gpg-result-buffer (get-buffer-create + (generate-new-buffer-name "*GnuPG Output*")))) + (unwind-protect + (gpg-show-result-buffer ,always-show (progn ,@body)) + (kill-buffer gpg-result-buffer)))) + +;;; Passphrase handling: + +(defvar gpg-passphrase-timer + (timer-create) + "This timer will clear the passphrase cache periodically.") + +(defvar gpg-passphrase + nil + "The (unencrypted) passphrase cache.") + +(defun gpg-passphrase-clear-string (str) + "Erases STR by overwriting all characters." + (let ((pos 0) + (len (length str))) + (while (< pos len) + (aset str pos ? ) + (incf pos)))) + +;;;###autoload +(defun gpg-passphrase-forget () + "Forget stored passphrase." + (interactive) + (cancel-timer gpg-passphrase-timer) + (gpg-passphrase-clear-string gpg-passphrase) + (setq gpg-passphrase nil)) + +(defun gpg-passphrase-store (passphrase) + "Store PASSPHRASE in cache. +Updates the timeout for clearing the cache to `gpg-passphrase-timeout'." + (unless (equal gpg-passphrase-timeout 0) + (timer-set-time gpg-passphrase-timer + (timer-relative-time (current-time) + gpg-passphrase-timeout)) + (timer-set-function gpg-passphrase-timer 'gpg-passphrase-forget) + (timer-activate gpg-passphrase-timer) + (setq gpg-passphrase passphrase)) + passphrase) + +(defun gpg-passphrase-read () + "Read a passphrase and remember it for some time." + (interactive) + (if gpg-passphrase + ;; This reinitializes the timer. + (gpg-passphrase-store gpg-passphrase) + (let ((pp (read-passwd "Enter passphrase: "))) + (gpg-passphrase-store pp)))) + + +;;;; Main operations: + +;;;###autoload +(defun gpg-verify (message signature result) + "Verify buffer MESSAGE against detached SIGNATURE buffer. +Returns t if everything worked out well, nil otherwise. Consult +buffer RESULT for details." + (interactive "bBuffer containing message: \nbBuffer containing signature: \nbBuffor for result: ") + (gpg-with-temp-files 2 + (let* ((sig-file (nth 0 gpg-temp-files)) + (msg-file (nth 1 gpg-temp-files)) + (cmd (gpg-exec-path gpg-command-verify)) + (args (gpg-build-arg-list (cdr gpg-command-verify) + `((signature-file . ,sig-file) + (message-file . ,msg-file)))) + res) + (with-temp-file sig-file + (buffer-disable-undo) + (apply 'insert-buffer-substring (if (listp signature) + signature + (list signature)))) + (with-temp-file msg-file + (buffer-disable-undo) + (apply 'insert-buffer-substring (if (listp message) + message + (list message)))) + (setq res (apply 'call-process-region + (point-min) (point-min) ; no data + cmd + nil ; don't delete + result + nil ; don't display + args)) + (if (or (stringp res) (> res 0)) + ;; Signal or abnormal exit. + (with-current-buffer result + (insert (format "\nCommand exit status: %s\n" res)) + nil) + t)))) + +;;;###autoload +(defun gpg-decrypt (ciphertext plaintext result &optional passphrase) + "Decrypt buffer CIPHERTEXT to buffer PLAINTEXT. +Returns t if everything worked out well, nil otherwise. Consult +buffer RESULT for details. Reads a missing PASSPHRASE using +`gpg-passphrase-read'." + (interactive "bBuffer containing ciphertext: \nbBuffer for plaintext: \nbBuffor for decryption status: ") + (gpg-call-process (gpg-exec-path gpg-command-decrypt) + (gpg-build-arg-list (cdr gpg-command-decrypt) nil) + ciphertext plaintext result + (if passphrase passphrase (gpg-passphrase-read))) + (when passphrase + (gpg-passphrase-clear-string passphrase))) + +;;;###autoload +(defun gpg-sign-cleartext + (plaintext signed-text result &optional passphrase sign-with-key) + "Sign buffer PLAINTEXT, and store PLAINTEXT with signature in +SIGNED-TEXT. +Reads a missing PASSPHRASE using `gpg-passphrase-read'. Uses key ID +SIGN-WITH-KEY if given, otherwise the default key ID. Returns t if +everything worked out well, nil otherwise. Consult buffer RESULT for +details. + +NOTE: Use of this function is deprecated." + (interactive "bBuffer containing plaintext: \nbBuffer for text with signature: \nbBuffer for status information: ") + (let ((subst (list (cons 'sign-with-key + (gpg-build-flag-sign-with-key sign-with-key)) + (cons 'armor gpg-command-flag-armor) + (cons 'textmode gpg-command-flag-textmode)))) + (gpg-call-process (gpg-exec-path gpg-command-sign-cleartext) + (gpg-build-arg-list (cdr gpg-command-sign-cleartext) + subst) + plaintext signed-text result + (if passphrase passphrase (gpg-passphrase-read)))) + (when passphrase + (gpg-passphrase-clear-string passphrase))) + +;;;###autoload +(defun gpg-sign-detached + (plaintext signature result &optional passphrase sign-with-key + armor textmode) + "Sign buffer PLAINTEXT, and store SIGNATURE in that buffer. +Reads a missing PASSPHRASE using `gpg-passphrase-read'. Uses key ID +SIGN-WITH-KEY if given, otherwise the default key ID. Returns t if +everything worked out well, nil otherwise. Consult buffer RESULT for +details. ARMOR the result and activate canonical TEXTMODE if +requested." + (interactive "bBuffer containing plaintext: \nbBuffer for text with signature: \nbBuffer for status information: ") + (let ((subst (list (cons 'sign-with-key + (gpg-build-flag-sign-with-key sign-with-key)) + (cons 'armor (if armor gpg-command-flag-armor)) + (cons 'textmode (if armor gpg-command-flag-textmode))))) + (gpg-call-process (gpg-exec-path gpg-command-sign-detached) + (gpg-build-arg-list (cdr gpg-command-sign-detached) + subst) + plaintext signature result + (if passphrase passphrase (gpg-passphrase-read)))) + (when passphrase + (gpg-passphrase-clear-string passphrase))) + + +;;;###autoload +(defun gpg-sign-encrypt + (plaintext ciphertext result recipients &optional passphrase sign-with-key + armor textmode) + "Sign buffer PLAINTEXT, and store SIGNATURE in that buffer. +RECIPIENTS is a list of key IDs used for encryption. This function +reads a missing PASSPHRASE using `gpg-passphrase-read', and uses key +ID SIGN-WITH-KEY for the signature if given, otherwise the default key +ID. Returns t if everything worked out well, nil otherwise. Consult +buffer RESULT for details. ARMOR the result and activate canonical +TEXTMODE if requested." + (interactive (list + (read-buffer "Buffer containing plaintext: " nil t) + (read-buffer "Buffer for ciphertext: " nil t) + (read-buffer "Buffer for status informationt: " nil t) + (gpg-read-recipients))) + (let ((subst `((sign-with-key . ,(gpg-build-flag-sign-with-key + sign-with-key)) + (plaintext-file . stdin-file) + (recipients . ,(gpg-build-flag-recipients recipients)) + (armor ,(if armor gpg-command-flag-armor)) + (textmode ,(if armor gpg-command-flag-textmode))))) + (gpg-call-process (gpg-exec-path gpg-command-sign-encrypt) + (gpg-build-arg-list (cdr gpg-command-sign-encrypt) + subst) + plaintext ciphertext result + (if passphrase passphrase (gpg-passphrase-read)))) + (when passphrase + (gpg-passphrase-clear-string passphrase))) + + +;;;###autoload +(defun gpg-encrypt + (plaintext ciphertext result recipients &optional passphrase armor textmode) + "Encrypt buffer PLAINTEXT, and store CIPHERTEXT in that buffer. +RECIPIENTS is a list of key IDs used for encryption. Returns t if +everything worked out well, nil otherwise. Consult buffer RESULT for +details. ARMOR the result and activate canonical +TEXTMODE if requested." + (interactive (list + (read-buffer "Buffer containing plaintext: " nil t) + (read-buffer "Buffer for ciphertext: " nil t) + (read-buffer "Buffer for status informationt: " nil t) + (gpg-read-recipients))) + (let ((subst `((plaintext-file . stdin-file) + (recipients . ,(gpg-build-flag-recipients recipients)) + (armor ,(if armor gpg-command-flag-armor)) + (textmode ,(if armor gpg-command-flag-textmode))))) + (gpg-call-process (gpg-exec-path gpg-command-encrypt) + (gpg-build-arg-list (cdr gpg-command-encrypt) subst) + plaintext ciphertext result nil)) + (when passphrase + (gpg-passphrase-clear-string passphrase))) + + +;;;; Key management + +;;; ADT: OpenPGP Key + +(defun gpg-key-make (user-id key-id unique-id length algorithm + creation-date expire-date validity trust) + "Create a new key object (for internal use only)." + (vector + ;; 0 1 2 3 4 + user-id key-id unique-id length algorithm + ;; 5 6 7 8 + creation-date expire-date validity trust)) + + +(defun gpg-key-p (key) + "Return t if KEY is a key specification." + (and (arrayp key) (equal (length key) 9) key)) + +(defmacro gpg-key-primary-user-id (key) + "The primary user ID for KEY (human-readable). +DO NOT USE this ID for selecting recipients. It is probably not +unique." + (list 'car (list 'aref key 0))) + +(defmacro gpg-key-user-ids (key) + "A list of additional user IDs for KEY (human-readable). +DO NOT USE these IDs for selecting recipients. They are probably not +unique." + (list 'cdr (list 'aref key 0))) + +(defmacro gpg-key-id (key) + "The key ID of KEY. +DO NOT USE this ID for selecting recipients. It is not guaranteed to +be unique." + (list 'aref key 1)) + +(defun gpg-short-key-id (key) + "The short key ID of KEY." + (let* ((id (gpg-key-id key)) + (len (length id))) + (if (> len 8) + (substring id (- len 8)) + id))) + +(defmacro gpg-key-unique-id (key) + "A non-standard ID of KEY which is only valid locally. +This ID can be used to specify recipients in a safe manner. Note, +even this ID might not be unique unless GnuPG is used." + (list 'aref key 2)) + +(defmacro gpg-key-unique-id-list (key-list) + "Like `gpg-key-unique-id', but operate on a list." + `(mapcar (lambda (key) (gpg-key-unique-id key)) + ,key-list)) + +(defmacro gpg-key-length (key) + "Returns the key length." + (list 'aref key 3)) + +(defmacro gpg-key-algorithm (key) + "The encryption algorithm used by KEY. +One of the symbols `rsa', `rsa-encrypt', `rsa-sign', `elgamal', +`elgamal-encrypt', `dsa'." + (list 'aref key 4)) + +(defmacro gpg-key-creation-date (key) + "A string with the creation date of KEY in ISO format." + (list 'aref key 5)) + +(defmacro gpg-key-expire-date (key) + "A string with the expiration date of KEY in ISO format." + (list 'aref key 6)) + +(defmacro gpg-key-validity (key) + "The calculated validity of KEY. +One of the symbols `not-known', `disabled', `revoked', `expired', +`undefined', `trust-none', `trust-marginal', `trust-full', +`trust-ultimate' (see the GnuPG documentation for details)." + (list 'aref key 7)) + +(defmacro gpg-key-trust (key) + "The assigned trust for KEY. +One of the symbols `not-known', `undefined', `trust-none', +`trust-marginal', `trust-full' (see the GnuPG +documentation for details)." + (list 'aref key 8)) + +(defun gpg-key-lessp (a b) + "Returns t if primary user ID of A is less than B." + (let ((res (compare-strings (gpg-key-primary-user-id a) 0 nil + (gpg-key-primary-user-id b) 0 nil + t))) + (if (eq res t) + nil + (< res 0)))) + +;;; Accessing the key database: + +;; Internal functions: + +(defmacro gpg-key-list-keys-skip-field () + '(search-forward ":" eol 'move)) + +(defmacro gpg-key-list-keys-get-field () + '(buffer-substring (point) (if (gpg-key-list-keys-skip-field) + (1- (point)) + eol))) +(defmacro gpg-key-list-keys-string-field () + '(gpg-key-list-keys-get-field)) + +(defmacro gpg-key-list-keys-read-field () + (let ((field (make-symbol "field"))) + `(let ((,field (gpg-key-list-keys-get-field))) + (if (equal (length ,field) 0) + nil + (read ,field))))) + +(defun gpg-key-list-keys-parse-line () + "Parse the line in the current buffer and return a vector of fields." + (let* ((eol (line-end-position)) + (v (if (eolp) + nil + (vector + (gpg-key-list-keys-read-field) ; type + (gpg-key-list-keys-get-field) ; trust + (gpg-key-list-keys-read-field) ; key length + (gpg-key-list-keys-read-field) ; algorithm + (gpg-key-list-keys-get-field) ; key ID + (gpg-key-list-keys-get-field) ; creation data + (gpg-key-list-keys-get-field) ; expire + (gpg-key-list-keys-get-field) ; unique (local) ID + (gpg-key-list-keys-get-field) ; ownertrust + (gpg-key-list-keys-string-field) ; user ID + )))) + (if (eolp) + (when v + (forward-char 1)) + (error "Too many fields in GnuPG key database")) + v)) + +(defconst gpg-pubkey-algo-alist + '((1 . rsa) + (2 . rsa-encrypt-only) + (3 . rsa-sign-only) + (16 . elgamal-encrypt-only) + (17 . dsa) + (20 . elgamal)) + "Alist mapping OpenPGP public key algorithm numbers to symbols.") + +(defconst gpg-trust-alist + '((?- . not-known) + (?o . not-known) + (?d . disabled) + (?r . revoked) + (?e . expired) + (?q . trust-undefined) + (?n . trust-none) + (?m . trust-marginal) + (?f . trust-full) + (?u . trust-ultimate)) + "Alist mapping GnuPG trust value short forms to long symbols.") + +(defmacro gpg-key-list-keys-in-buffer-store () + '(when primary-user-id + (sort user-id 'string-lessp) + (push (gpg-key-make (cons primary-user-id user-id) + key-id unique-id key-length + algorithm creation-date + expire-date validity trust) + key-list))) + +(defun gpg-key-list-keys-in-buffer (&optional buffer) + "Return a list of keys for BUFFER. +If BUFFER is omitted, use current buffer." + (with-current-buffer (if buffer buffer (current-buffer)) + (goto-char (point-min)) + ;; Skip key ring filename written by GnuPG. + (search-forward "\n---------------------------\n" nil t) + ;; Loop over all lines in buffer and analyze them. + (let (primary-user-id user-id key-id unique-id ; current key components + key-length algorithm creation-date expire-date validity trust + line ; fields in current line + key-list) ; keys gather so far + + (while (setq line (gpg-key-list-keys-parse-line)) + (cond + ;; Public or secret key. + ((memq (aref line 0) '(pub sec)) + ;; Store previous key, if any. + (gpg-key-list-keys-in-buffer-store) + ;; Record field values. + (setq primary-user-id (aref line 9)) + (setq user-id nil) + (setq key-id (aref line 4)) + ;; We use the key ID if no unique ID is available. + (setq unique-id (if (> (length (aref line 7)) 0) + (concat "#" (aref line 7)) + (concat "0x" key-id))) + (setq key-length (aref line 2)) + (setq algorithm (assq (aref line 3) gpg-pubkey-algo-alist)) + (if algorithm + (setq algorithm (cdr algorithm)) + (error "Unknown algorithm %s" (aref line 3))) + (setq creation-date (if (> (length (aref line 5)) 0) + (aref line 5))) + (setq expire-date (if (> (length (aref line 6)) 0) + (aref line 6))) + (setq validity (assq (aref (aref line 1) 0) gpg-trust-alist)) + (if validity + (setq validity (cdr validity)) + (error "Unknown validity specification %S" (aref line 1))) + (setq trust (assq (aref (aref line 8) 0) gpg-trust-alist)) + (if trust + (setq trust (cdr trust)) + (error "Unknown trust specification %S" (aref line 8)))) + + ;; Additional user ID + ((eq 'uid (aref line 0)) + (setq user-id (cons (aref line 9) user-id))) + + ;; Subkeys are ignored for now. + ((memq (aref line 0) '(sub ssb)) + t) + (t (error "Unknown record type %S" (aref line 0))))) + + ;; Store the key retrieved last. + (gpg-key-list-keys-in-buffer-store) + ;; Sort the keys according to the primary user ID. + (sort key-list 'gpg-key-lessp)))) + +(defun gpg-key-list-keyspec (command &optional keyspec stderr ignore-error) + "Insert the output of COMMAND before point in current buffer." + (let* ((cmd (gpg-exec-path command)) + (key (if (equal keyspec "") nil keyspec)) + (args (gpg-build-arg-list (cdr command) `((key-id . ,key)))) + exit-status) + (setq exit-status + (apply 'call-process-region + (point-min) (point-min) ; no data + cmd + nil ; don't delete + (if stderr t '(t nil)) + nil ; don't display + args)) + (unless (or ignore-error (equal exit-status 0)) + (error "GnuPG command exited unsuccessfully")))) + + +(defun gpg-key-list-keyspec-parse (command &optional keyspec) + "Return a list of keys matching KEYSPEC. +COMMAND is used to obtain the key list. The usual substring search +for keys is performed." + (with-temp-buffer + (buffer-disable-undo) + (gpg-key-list-keyspec command keyspec) + (gpg-key-list-keys-in-buffer))) + +;;;###autoload +(defun gpg-key-list-keys (&optional keyspec) + "A list of public keys matching KEYSPEC. +The usual substring search for keys is performed." + (gpg-key-list-keyspec-parse gpg-command-key-public-ring keyspec)) + +;;;###autoload +(defun gpg-key-list-secret-keys (&optional keyspec) + "A list of secret keys matching KEYSPEC. +The usual substring search for keys is performed." + (gpg-key-list-keyspec-parse gpg-command-key-secret-ring keyspec)) + +;;;###autoload +(defun gpg-key-insert-public-key (key) + "Inserts the public key(s) matching KEYSPEC. +The ASCII-armored key is inserted before point into current buffer." + (gpg-key-list-keyspec gpg-command-key-export key)) + +;;;###autoload +(defun gpg-key-insert-information (key) + "Insert human-readable information (including fingerprint) on KEY. +Insertion takes place in current buffer before point." + (gpg-key-list-keyspec gpg-command-key-verify key)) + +;;;###autoload +(defun gpg-key-retrieve (key) + "Fetch KEY from default key server. +KEY is a key ID or a list of key IDs. Status information about this +operation is inserted into the current buffer before point." + (gpg-key-list-keyspec gpg-command-key-retrieve key t t)) + +;;;###autoload +(defun gpg-key-add-to-ring (key result) + "Adds key in buffer KEY to the GnuPG key ring. +Human-readable information on the RESULT is stored in buffer RESULT +before point.") + +(provide 'gpg) + +;;; gpg.el ends here diff --git a/contrib/md5.el b/contrib/md5.el new file mode 100644 index 0000000..94d65de --- /dev/null +++ b/contrib/md5.el @@ -0,0 +1,409 @@ +;;; md5.el -- MD5 Message Digest Algorithm +;;; Gareth Rees + +;; LCD Archive Entry: +;; md5|Gareth Rees|gdr11@cl.cam.ac.uk| +;; MD5 cryptographic message digest algorithm| +;; 13-Nov-95|1.0|~/misc/md5.el.Z| + +;;; Details: ------------------------------------------------------------------ + +;; This is a direct translation into Emacs LISP of the reference C +;; implementation of the MD5 Message-Digest Algorithm written by RSA +;; Data Security, Inc. +;; +;; The algorithm takes a message (that is, a string of bytes) and +;; computes a 16-byte checksum or "digest" for the message. This digest +;; is supposed to be cryptographically strong in the sense that if you +;; are given a 16-byte digest D, then there is no easier way to +;; construct a message whose digest is D than to exhaustively search the +;; space of messages. However, the robustness of the algorithm has not +;; been proven, and a similar algorithm (MD4) was shown to be unsound, +;; so treat with caution! +;; +;; The C algorithm uses 32-bit integers; because GNU Emacs +;; implementations provide 28-bit integers (with 24-bit integers on +;; versions prior to 19.29), the code represents a 32-bit integer as the +;; cons of two 16-bit integers. The most significant word is stored in +;; the car and the least significant in the cdr. The algorithm requires +;; at least 17 bits of integer representation in order to represent the +;; carry from a 16-bit addition. + +;;; Usage: -------------------------------------------------------------------- + +;; To compute the MD5 Message Digest for a message M (represented as a +;; string or as a vector of bytes), call +;; +;; (md5-encode M) +;; +;; which returns the message digest as a vector of 16 bytes. If you +;; need to supply the message in pieces M1, M2, ... Mn, then call +;; +;; (md5-init) +;; (md5-update M1) +;; (md5-update M2) +;; ... +;; (md5-update Mn) +;; (md5-final) + +;;; Copyright and licence: ---------------------------------------------------- + +;; Copyright (C) 1995 by Gareth Rees +;; Derived from the RSA Data Security, Inc. MD5 Message-Digest Algorithm +;; +;; md5.el 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. +;; +;; md5.el 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. +;; +;; The original copyright notice is given below, as required by the +;; licence for the original code. This code is distributed under *both* +;; RSA's original licence and the GNU General Public Licence. (There +;; should be no problems, as the former is more liberal than the +;; latter). + +;;; Original copyright notice: ------------------------------------------------ + +;; Copyright (C) 1990, RSA Data Security, Inc. All rights reserved. +;; +;; License to copy and use this software is granted provided that it is +;; identified as the "RSA Data Security, Inc. MD5 Message- Digest +;; Algorithm" in all material mentioning or referencing this software or +;; this function. +;; +;; License is also granted to make and use derivative works provided +;; that such works are identified as "derived from the RSA Data +;; Security, Inc. MD5 Message-Digest Algorithm" in all material +;; mentioning or referencing the derived work. +;; +;; RSA Data Security, Inc. makes no representations concerning either +;; the merchantability of this software or the suitability of this +;; software for any particular purpose. It is provided "as is" without +;; express or implied warranty of any kind. +;; +;; These notices must be retained in any copies of any part of this +;; documentation and/or software. + +;;; Code: --------------------------------------------------------------------- + +(defvar md5-program "md5sum" + "*Program that reads a message on its standard input and writes an +MD5 digest on its output.") + +(defvar md5-maximum-internal-length 4096 + "*The maximum size of a piece of data that should use the MD5 routines +written in lisp. If a message exceeds this, it will be run through an +external filter for processing. Also see the `md5-program' variable. +This variable has no effect if you call the md5-init|update|final +functions - only used by the `md5' function's simpler interface.") + +(defvar md5-bits (make-vector 4 0) + "Number of bits handled, modulo 2^64. +Represented as four 16-bit numbers, least significant first.") +(defvar md5-buffer (make-vector 4 '(0 . 0)) + "Scratch buffer (four 32-bit integers).") +(defvar md5-input (make-vector 64 0) + "Input buffer (64 bytes).") + +(defun md5-unhex (x) + (if (> x ?9) + (if (>= x ?a) + (+ 10 (- x ?a)) + (+ 10 (- x ?A))) + (- x ?0))) + +(defun md5-encode (message) + "Encodes MESSAGE using the MD5 message digest algorithm. +MESSAGE must be a string or an array of bytes. +Returns a vector of 16 bytes containing the message digest." + (if (<= (length message) md5-maximum-internal-length) + (progn + (md5-init) + (md5-update message) + (md5-final)) + (save-excursion + (set-buffer (get-buffer-create " *md5-work*")) + (erase-buffer) + (insert message) + (call-process-region (point-min) (point-max) + (or shell-file-name "/bin/sh") + t (current-buffer) nil + "-c" md5-program) + ;; MD5 digest is 32 chars long + ;; mddriver adds a newline to make neaten output for tty + ;; viewing, make sure we leave it behind. + (let ((data (buffer-substring (point-min) (+ (point-min) 32))) + (vec (make-vector 16 0)) + (ctr 0)) + (while (< ctr 16) + (aset vec ctr (+ (* 16 (md5-unhex (aref data (* ctr 2)))) + (md5-unhex (aref data (1+ (* ctr 2)))))) + (setq ctr (1+ ctr))))))) + +(defsubst md5-add (x y) + "Return 32-bit sum of 32-bit integers X and Y." + (let ((m (+ (car x) (car y))) + (l (+ (cdr x) (cdr y)))) + (cons (logand 65535 (+ m (lsh l -16))) (logand l 65535)))) + +;; FF, GG, HH and II are basic MD5 functions, providing transformations +;; for rounds 1, 2, 3 and 4 respectively. Each function follows this +;; pattern of computation (where ROTATE(x,y) means rotate 32-bit value x +;; by y bits to the left): +;; +;; FF(a,b,c,d,x,s,ac) = ROTATE(a + F(b,c,d) + x + ac,s) + b +;; +;; so we use the macro `md5-make-step' to construct each one. The +;; helper functions F, G, H and I operate on 16-bit numbers; the full +;; operation splits its inputs, operates on the halves separately and +;; then puts the results together. + +(defsubst md5-F (x y z) (logior (logand x y) (logand (lognot x) z))) +(defsubst md5-G (x y z) (logior (logand x z) (logand y (lognot z)))) +(defsubst md5-H (x y z) (logxor x y z)) +(defsubst md5-I (x y z) (logxor y (logior x (logand 65535 (lognot z))))) + +(defmacro md5-make-step (name func) + (` + (defun (, name) (a b c d x s ac) + (let* + ((m1 (+ (car a) ((, func) (car b) (car c) (car d)) (car x) (car ac))) + (l1 (+ (cdr a) ((, func) (cdr b) (cdr c) (cdr d)) (cdr x) (cdr ac))) + (m2 (logand 65535 (+ m1 (lsh l1 -16)))) + (l2 (logand 65535 l1)) + (m3 (logand 65535 (if (> s 15) + (+ (lsh m2 (- s 32)) (lsh l2 (- s 16))) + (+ (lsh m2 s) (lsh l2 (- s 16)))))) + (l3 (logand 65535 (if (> s 15) + (+ (lsh l2 (- s 32)) (lsh m2 (- s 16))) + (+ (lsh l2 s) (lsh m2 (- s 16))))))) + (md5-add (cons m3 l3) b))))) + +(md5-make-step md5-FF md5-F) +(md5-make-step md5-GG md5-G) +(md5-make-step md5-HH md5-H) +(md5-make-step md5-II md5-I) + +(defun md5-init () + "Initialise the state of the message-digest routines." + (aset md5-bits 0 0) + (aset md5-bits 1 0) + (aset md5-bits 2 0) + (aset md5-bits 3 0) + (aset md5-buffer 0 '(26437 . 8961)) + (aset md5-buffer 1 '(61389 . 43913)) + (aset md5-buffer 2 '(39098 . 56574)) + (aset md5-buffer 3 '( 4146 . 21622))) + +(defun md5-update (string) + "Update the current MD5 state with STRING (an array of bytes)." + (let ((len (length string)) + (i 0) + (j 0)) + (while (< i len) + ;; Compute number of bytes modulo 64 + (setq j (% (/ (aref md5-bits 0) 8) 64)) + + ;; Store this byte (truncating to 8 bits to be sure) + (aset md5-input j (logand 255 (aref string i))) + + ;; Update number of bits by 8 (modulo 2^64) + (let ((c 8) (k 0)) + (while (and (> c 0) (< k 4)) + (let ((b (aref md5-bits k))) + (aset md5-bits k (logand 65535 (+ b c))) + (setq c (if (> b (- 65535 c)) 1 0) + k (1+ k))))) + + ;; Increment number of bytes processed + (setq i (1+ i)) + + ;; When 64 bytes accumulated, pack them into sixteen 32-bit + ;; integers in the array `in' and then tranform them. + (if (= j 63) + (let ((in (make-vector 16 (cons 0 0))) + (k 0) + (kk 0)) + (while (< k 16) + (aset in k (md5-pack md5-input kk)) + (setq k (+ k 1) kk (+ kk 4))) + (md5-transform in)))))) + +(defun md5-pack (array i) + "Pack the four bytes at ARRAY reference I to I+3 into a 32-bit integer." + (cons (+ (lsh (aref array (+ i 3)) 8) (aref array (+ i 2))) + (+ (lsh (aref array (+ i 1)) 8) (aref array (+ i 0))))) + +(defun md5-byte (array n b) + "Unpack byte B (0 to 3) from Nth member of ARRAY of 32-bit integers." + (let ((e (aref array n))) + (cond ((eq b 0) (logand 255 (cdr e))) + ((eq b 1) (lsh (cdr e) -8)) + ((eq b 2) (logand 255 (car e))) + ((eq b 3) (lsh (car e) -8))))) + +(defun md5-final () + (let ((in (make-vector 16 (cons 0 0))) + (j 0) + (digest (make-vector 16 0)) + (padding)) + + ;; Save the number of bits in the message + (aset in 14 (cons (aref md5-bits 1) (aref md5-bits 0))) + (aset in 15 (cons (aref md5-bits 3) (aref md5-bits 2))) + + ;; Compute number of bytes modulo 64 + (setq j (% (/ (aref md5-bits 0) 8) 64)) + + ;; Pad out computation to 56 bytes modulo 64 + (setq padding (make-vector (if (< j 56) (- 56 j) (- 120 j)) 0)) + (aset padding 0 128) + (md5-update padding) + + ;; Append length in bits and transform + (let ((k 0) (kk 0)) + (while (< k 14) + (aset in k (md5-pack md5-input kk)) + (setq k (+ k 1) kk (+ kk 4)))) + (md5-transform in) + + ;; Store the results in the digest + (let ((k 0) (kk 0)) + (while (< k 4) + (aset digest (+ kk 0) (md5-byte md5-buffer k 0)) + (aset digest (+ kk 1) (md5-byte md5-buffer k 1)) + (aset digest (+ kk 2) (md5-byte md5-buffer k 2)) + (aset digest (+ kk 3) (md5-byte md5-buffer k 3)) + (setq k (+ k 1) kk (+ kk 4)))) + + ;; Return digest + digest)) + +;; It says in the RSA source, "Note that if the Mysterious Constants are +;; arranged backwards in little-endian order and decrypted with the DES +;; they produce OCCULT MESSAGES!" Security through obscurity? + +(defun md5-transform (in) + "Basic MD5 step. Transform md5-buffer based on array IN." + (let ((a (aref md5-buffer 0)) + (b (aref md5-buffer 1)) + (c (aref md5-buffer 2)) + (d (aref md5-buffer 3))) + (setq + a (md5-FF a b c d (aref in 0) 7 '(55146 . 42104)) + d (md5-FF d a b c (aref in 1) 12 '(59591 . 46934)) + c (md5-FF c d a b (aref in 2) 17 '( 9248 . 28891)) + b (md5-FF b c d a (aref in 3) 22 '(49597 . 52974)) + a (md5-FF a b c d (aref in 4) 7 '(62844 . 4015)) + d (md5-FF d a b c (aref in 5) 12 '(18311 . 50730)) + c (md5-FF c d a b (aref in 6) 17 '(43056 . 17939)) + b (md5-FF b c d a (aref in 7) 22 '(64838 . 38145)) + a (md5-FF a b c d (aref in 8) 7 '(27008 . 39128)) + d (md5-FF d a b c (aref in 9) 12 '(35652 . 63407)) + c (md5-FF c d a b (aref in 10) 17 '(65535 . 23473)) + b (md5-FF b c d a (aref in 11) 22 '(35164 . 55230)) + a (md5-FF a b c d (aref in 12) 7 '(27536 . 4386)) + d (md5-FF d a b c (aref in 13) 12 '(64920 . 29075)) + c (md5-FF c d a b (aref in 14) 17 '(42617 . 17294)) + b (md5-FF b c d a (aref in 15) 22 '(18868 . 2081)) + a (md5-GG a b c d (aref in 1) 5 '(63006 . 9570)) + d (md5-GG d a b c (aref in 6) 9 '(49216 . 45888)) + c (md5-GG c d a b (aref in 11) 14 '( 9822 . 23121)) + b (md5-GG b c d a (aref in 0) 20 '(59830 . 51114)) + a (md5-GG a b c d (aref in 5) 5 '(54831 . 4189)) + d (md5-GG d a b c (aref in 10) 9 '( 580 . 5203)) + c (md5-GG c d a b (aref in 15) 14 '(55457 . 59009)) + b (md5-GG b c d a (aref in 4) 20 '(59347 . 64456)) + a (md5-GG a b c d (aref in 9) 5 '( 8673 . 52710)) + d (md5-GG d a b c (aref in 14) 9 '(49975 . 2006)) + c (md5-GG c d a b (aref in 3) 14 '(62677 . 3463)) + b (md5-GG b c d a (aref in 8) 20 '(17754 . 5357)) + a (md5-GG a b c d (aref in 13) 5 '(43491 . 59653)) + d (md5-GG d a b c (aref in 2) 9 '(64751 . 41976)) + c (md5-GG c d a b (aref in 7) 14 '(26479 . 729)) + b (md5-GG b c d a (aref in 12) 20 '(36138 . 19594)) + a (md5-HH a b c d (aref in 5) 4 '(65530 . 14658)) + d (md5-HH d a b c (aref in 8) 11 '(34673 . 63105)) + c (md5-HH c d a b (aref in 11) 16 '(28061 . 24866)) + b (md5-HH b c d a (aref in 14) 23 '(64997 . 14348)) + a (md5-HH a b c d (aref in 1) 4 '(42174 . 59972)) + d (md5-HH d a b c (aref in 4) 11 '(19422 . 53161)) + c (md5-HH c d a b (aref in 7) 16 '(63163 . 19296)) + b (md5-HH b c d a (aref in 10) 23 '(48831 . 48240)) + a (md5-HH a b c d (aref in 13) 4 '(10395 . 32454)) + d (md5-HH d a b c (aref in 0) 11 '(60065 . 10234)) + c (md5-HH c d a b (aref in 3) 16 '(54511 . 12421)) + b (md5-HH b c d a (aref in 6) 23 '( 1160 . 7429)) + a (md5-HH a b c d (aref in 9) 4 '(55764 . 53305)) + d (md5-HH d a b c (aref in 12) 11 '(59099 . 39397)) + c (md5-HH c d a b (aref in 15) 16 '( 8098 . 31992)) + b (md5-HH b c d a (aref in 2) 23 '(50348 . 22117)) + a (md5-II a b c d (aref in 0) 6 '(62505 . 8772)) + d (md5-II d a b c (aref in 7) 10 '(17194 . 65431)) + c (md5-II c d a b (aref in 14) 15 '(43924 . 9127)) + b (md5-II b c d a (aref in 5) 21 '(64659 . 41017)) + a (md5-II a b c d (aref in 12) 6 '(25947 . 22979)) + d (md5-II d a b c (aref in 3) 10 '(36620 . 52370)) + c (md5-II c d a b (aref in 10) 15 '(65519 . 62589)) + b (md5-II b c d a (aref in 1) 21 '(34180 . 24017)) + a (md5-II a b c d (aref in 8) 6 '(28584 . 32335)) + d (md5-II d a b c (aref in 15) 10 '(65068 . 59104)) + c (md5-II c d a b (aref in 6) 15 '(41729 . 17172)) + b (md5-II b c d a (aref in 13) 21 '(19976 . 4513)) + a (md5-II a b c d (aref in 4) 6 '(63315 . 32386)) + d (md5-II d a b c (aref in 11) 10 '(48442 . 62005)) + c (md5-II c d a b (aref in 2) 15 '(10967 . 53947)) + b (md5-II b c d a (aref in 9) 21 '(60294 . 54161))) + + (aset md5-buffer 0 (md5-add (aref md5-buffer 0) a)) + (aset md5-buffer 1 (md5-add (aref md5-buffer 1) b)) + (aset md5-buffer 2 (md5-add (aref md5-buffer 2) c)) + (aset md5-buffer 3 (md5-add (aref md5-buffer 3) d)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Here begins the merger with the XEmacs API and the md5.el from the URL +;;; package. Courtesy wmperry@spry.com +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun md5 (object &optional start end) + "Return the MD5 (a secure message digest algorithm) of an object. +OBJECT is either a string or a buffer. +Optional arguments START and END denote buffer positions for computing the +hash of a portion of OBJECT." + (let ((buffer nil)) + (unwind-protect + (save-excursion + (setq buffer (generate-new-buffer " *md5-work*")) + (set-buffer buffer) + (cond + ((bufferp object) + (insert-buffer-substring object start end)) + ((stringp object) + (insert (if (or start end) + (substring object start end) + object))) + (t nil)) + (prog1 + (if (<= (point-max) md5-maximum-internal-length) + (mapconcat + (function (lambda (node) (format "%02x" node))) + (md5-encode (buffer-string)) + "") + (call-process-region (point-min) (point-max) + (or shell-file-name "/bin/sh") + t buffer nil + "-c" md5-program) + ;; MD5 digest is 32 chars long + ;; mddriver adds a newline to make neaten output for tty + ;; viewing, make sure we leave it behind. + (buffer-substring (point-min) (+ (point-min) 32))) + (kill-buffer buffer))) + (and buffer (kill-buffer buffer) nil)))) + +(provide 'md5) + +;;; md5.el ends here ---------------------------------------------------------- diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 08d11b8..6e0a3d5 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,83 @@ +2000-11-05 Simon Josefsson + + * mml-smime.el (mml-smime-sign): Not used. + (mml-smime-encrypt): Ditto. + + * mm-decode.el (mml-smime-verify): Autoload mml-smime. + + Verify S/MIME signature support. + + * mm-decode.el (mm-inline-media-tests): Add + application/{x-,}pkcs7-signature. + (mm-inlined-types): Ditto. + (mm-automatic-display): Ditto. + (mm-verify-function-alist): Ditto. Add name of method. + (mm-decrypt-function-alist): Add name of method. + (mm-find-part-by-type): Add documentation. + (mm-possibly-verify-or-decrypt): Use new format of + mm-{verify,decrypt}-function-alist. Use method names. + + * mml-smime.el (mml-smime-verify): New function. + +2000-11-04 20:38:50 ShengHuo ZHU + + * mm-view.el (mm-inline-text): Move point to the end of inserted text. + +2000-11-04 19:07:08 ShengHuo ZHU + + * mml2015.el (mml2015-function-alist): Clear verify and decrypt. + * mm-uu.el: Reorganized. Add gnatsweb, pgp-signed, pgp-encrypted. + * mm-decode.el (mm-snarf-option): New. + +2000-11-04 13:08:02 ShengHuo ZHU + + * mm-util.el (mm-subst-char-in-string): New function. + (mm-replace-chars-in-string): Use it. + * message.el (message-replace-chars-in-string): Use it. + * nnheader.el (nnheader-replace-chars-in-string): Use it. + * gnus-mh.el (mh-lib-progs): Shut up. + +2000-11-04 ShengHuo Zhu + + * base64.el, md5.el: Moved to contrib directory. + +2000-11-04 11:13:56 ShengHuo ZHU + + * gnus-sum.el (gnus-summary-search-article-forward): Don't move + the last article when search. + +2000-11-04 10:34:29 ShengHuo ZHU + + * nnheader.el (nnheader-pathname-coding-system): Default iso-8859-1. + * nnmail.el (nnmail-pathname-coding-system): Ditto. + +2000-09-29 David Edmondson + + One-line patch. + + * message.el (message-newline-and-reformat): Typo. + +2000-11-04 10:11:05 ShengHuo ZHU + + * rfc2231.el (rfc2231-decode-encoded-string): Test mm-multibyte-p. + +2000-11-04 09:53:42 ShengHuo ZHU + + * nntp.el (nntp-decode-text): Delete bogus status lines. + +2000-11-03 Stefan Monnier + + * message.el (message-font-lock-keywords): Match a final newline + to help font-lock's multiline support. + +2000-11-04 09:11:44 ShengHuo ZHU + + * nnoo.el (nnoo-set): New function. + +2000-11-04 ShengHuo Zhu + + * gpg.el, gpg-ring.el: Moved to contrib directory. + 2000-11-04 Simon Josefsson * nnimap.el (nnimap-split-inbox): Typo. diff --git a/lisp/base64.el b/lisp/base64.el deleted file mode 100644 index 8ca14a6..0000000 --- a/lisp/base64.el +++ /dev/null @@ -1,305 +0,0 @@ -;;; base64.el,v --- Base64 encoding functions -;; Author: Kyle E. Jones -;; Created: 1997/03/12 14:37:09 -;; Version: 1.6 -;; Keywords: extensions - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Copyright (C) 1997 Kyle E. Jones -;;; -;;; This file is not part of GNU Emacs, but the same permissions apply. -;;; -;;; 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. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(eval-when-compile (require 'static)) - -(require 'mel) - -(eval-and-compile - (defun autoload-functionp (object) - (if (functionp object) - (let ((def object)) - (while (and (symbolp def) (fboundp def)) - (setq def (symbol-function def))) - (eq (car-safe def) 'autoload)))) - (if (autoload-functionp 'base64-decode-string) - (fmakunbound 'base64-decode-string)) - (if (autoload-functionp 'base64-decode-region) - (fmakunbound 'base64-decode-region)) - (if (autoload-functionp 'base64-encode-string) - (fmakunbound 'base64-encode-string)) - (if (autoload-functionp 'base64-encode-region) - (fmakunbound 'base64-encode-region)) - (mel-find-function 'mime-decode-string "base64") - (mel-find-function 'mime-decode-region "base64") - (mel-find-function 'mime-encode-string "base64") - (mel-find-function 'mime-encode-region "base64")) - -(static-when nil -(eval-when-compile (require 'cl)) - -;; For non-MULE -(if (not (fboundp 'char-int)) - (defalias 'char-int 'identity)) - -(defvar base64-alphabet - "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/") - -(defvar base64-decoder-program nil - "*Non-nil value should be a string that names a MIME base64 decoder. -The program should expect to read base64 data on its standard -input and write the converted data to its standard output.") - -(defvar base64-decoder-switches nil - "*List of command line flags passed to the command named by -base64-decoder-program.") - -(defvar base64-encoder-program nil - "*Non-nil value should be a string that names a MIME base64 encoder. -The program should expect arbitrary data on its standard -input and write base64 data to its standard output.") - -(defvar base64-encoder-switches nil - "*List of command line flags passed to the command named by -base64-encoder-program.") - -(defconst base64-alphabet-decoding-alist - '( - ( ?A . 00) ( ?B . 01) ( ?C . 02) ( ?D . 03) ( ?E . 04) ( ?F . 05) - ( ?G . 06) ( ?H . 07) ( ?I . 08) ( ?J . 09) ( ?K . 10) ( ?L . 11) - ( ?M . 12) ( ?N . 13) ( ?O . 14) ( ?P . 15) ( ?Q . 16) ( ?R . 17) - ( ?S . 18) ( ?T . 19) ( ?U . 20) ( ?V . 21) ( ?W . 22) ( ?X . 23) - ( ?Y . 24) ( ?Z . 25) ( ?a . 26) ( ?b . 27) ( ?c . 28) ( ?d . 29) - ( ?e . 30) ( ?f . 31) ( ?g . 32) ( ?h . 33) ( ?i . 34) ( ?j . 35) - ( ?k . 36) ( ?l . 37) ( ?m . 38) ( ?n . 39) ( ?o . 40) ( ?p . 41) - ( ?q . 42) ( ?r . 43) ( ?s . 44) ( ?t . 45) ( ?u . 46) ( ?v . 47) - ( ?w . 48) ( ?x . 49) ( ?y . 50) ( ?z . 51) ( ?0 . 52) ( ?1 . 53) - ( ?2 . 54) ( ?3 . 55) ( ?4 . 56) ( ?5 . 57) ( ?6 . 58) ( ?7 . 59) - ( ?8 . 60) ( ?9 . 61) ( ?+ . 62) ( ?/ . 63) - )) - -(defvar base64-alphabet-decoding-vector - (let ((v (make-vector 123 nil)) - (p base64-alphabet-decoding-alist)) - (while p - (aset v (car (car p)) (cdr (car p))) - (setq p (cdr p))) - v)) - -(defvar base64-binary-coding-system 'binary) - -(defun base64-run-command-on-region (start end output-buffer command - &rest arg-list) - (let ((tempfile nil) status errstring default-process-coding-system - (coding-system-for-write base64-binary-coding-system) - (coding-system-for-read base64-binary-coding-system)) - (unwind-protect - (progn - (setq tempfile (make-temp-name "base64")) - (setq status - (apply 'call-process-region - start end command nil - (list output-buffer tempfile) - nil arg-list)) - (cond ((equal status 0) t) - ((zerop (save-excursion - (set-buffer (find-file-noselect tempfile)) - (buffer-size))) - t) - (t (save-excursion - (set-buffer (find-file-noselect tempfile)) - (setq errstring (buffer-string)) - (kill-buffer nil) - (cons status errstring))))) - (ignore-errors - (delete-file tempfile))))) - -(if (featurep 'xemacs) - (defalias 'base64-insert-char 'insert-char) - (defun base64-insert-char (char &optional count ignored buffer) - (if (or (null buffer) (eq buffer (current-buffer))) - (insert-char char count) - (with-current-buffer buffer - (insert-char char count)))) - (setq base64-binary-coding-system 'no-conversion)) - -(defun base64-decode-region (start end) - (interactive "r") - ;;(message "Decoding base64...") - (let ((work-buffer nil) - (done nil) - (counter 0) - (bits 0) - (lim 0) inputpos - (non-data-chars (concat "^=" base64-alphabet))) - (unwind-protect - (save-excursion - (setq work-buffer (generate-new-buffer " *base64-work*")) - (buffer-disable-undo work-buffer) - (if base64-decoder-program - (let* ((binary-process-output t) ; any text already has CRLFs - (status (apply 'base64-run-command-on-region - start end work-buffer - base64-decoder-program - base64-decoder-switches))) - (if (not (eq status t)) - (error "%s" (cdr status)))) - (goto-char start) - (skip-chars-forward non-data-chars end) - (while (not done) - (setq inputpos (point)) - (cond - ((> (skip-chars-forward base64-alphabet end) 0) - (setq lim (point)) - (while (< inputpos lim) - (setq bits (+ bits - (aref base64-alphabet-decoding-vector - (char-int (char-after inputpos))))) - (setq counter (1+ counter) - inputpos (1+ inputpos)) - (cond ((= counter 4) - (base64-insert-char (lsh bits -16) 1 nil work-buffer) - (base64-insert-char (logand (lsh bits -8) 255) 1 nil - work-buffer) - (base64-insert-char (logand bits 255) 1 nil - work-buffer) - (setq bits 0 counter 0)) - (t (setq bits (lsh bits 6))))))) - (cond - ((or (= (point) end) - (eq (char-after (point)) ?=)) - (if (and (= (point) end) (> counter 1)) - (message - "at least %d bits missing at end of base64 encoding" - (* (- 4 counter) 6))) - (setq done t) - (cond ((= counter 1) - (error "at least 2 bits missing at end of base64 encoding")) - ((= counter 2) - (base64-insert-char (lsh bits -10) 1 nil work-buffer)) - ((= counter 3) - (base64-insert-char (lsh bits -16) 1 nil work-buffer) - (base64-insert-char (logand (lsh bits -8) 255) - 1 nil work-buffer)) - ((= counter 0) t))) - (t (skip-chars-forward non-data-chars end))))) - (or (markerp end) (setq end (set-marker (make-marker) end))) - (goto-char start) - (insert-buffer-substring work-buffer) - (delete-region (point) end)) - (and work-buffer (kill-buffer work-buffer)))) - ;;(message "Decoding base64... done") - ) - -(defun base64-encode-region (start end &optional no-line-break) - (interactive "r") - (message "Encoding base64...") - (let ((work-buffer nil) - (counter 0) - (cols 0) - (bits 0) - (alphabet base64-alphabet) - inputpos) - (unwind-protect - (save-excursion - (setq work-buffer (generate-new-buffer " *base64-work*")) - (buffer-disable-undo work-buffer) - (if base64-encoder-program - (let ((status (apply 'base64-run-command-on-region - start end work-buffer - base64-encoder-program - base64-encoder-switches))) - (if (not (eq status t)) - (error "%s" (cdr status)))) - (setq inputpos start) - (while (< inputpos end) - (setq bits (+ bits (char-int (char-after inputpos)))) - (setq counter (1+ counter)) - (cond ((= counter 3) - (base64-insert-char (aref alphabet (lsh bits -18)) 1 nil - work-buffer) - (base64-insert-char - (aref alphabet (logand (lsh bits -12) 63)) - 1 nil work-buffer) - (base64-insert-char - (aref alphabet (logand (lsh bits -6) 63)) - 1 nil work-buffer) - (base64-insert-char - (aref alphabet (logand bits 63)) - 1 nil work-buffer) - (setq cols (+ cols 4)) - (cond ((and (= cols 72) - (not no-line-break)) - (base64-insert-char ?\n 1 nil work-buffer) - (setq cols 0))) - (setq bits 0 counter 0)) - (t (setq bits (lsh bits 8)))) - (setq inputpos (1+ inputpos))) - ;; write out any remaining bits with appropriate padding - (if (= counter 0) - nil - (setq bits (lsh bits (- 16 (* 8 counter)))) - (base64-insert-char (aref alphabet (lsh bits -18)) 1 nil - work-buffer) - (base64-insert-char (aref alphabet (logand (lsh bits -12) 63)) - 1 nil work-buffer) - (if (= counter 1) - (base64-insert-char ?= 2 nil work-buffer) - (base64-insert-char (aref alphabet (logand (lsh bits -6) 63)) - 1 nil work-buffer) - (base64-insert-char ?= 1 nil work-buffer))) - (if (and (> cols 0) - (not no-line-break)) - (base64-insert-char ?\n 1 nil work-buffer))) - (or (markerp end) (setq end (set-marker (make-marker) end))) - (goto-char start) - (insert-buffer-substring work-buffer) - (delete-region (point) end)) - (and work-buffer (kill-buffer work-buffer)))) - (message "Encoding base64... done")) - -(defun base64-encode (string &optional no-line-break) - (save-excursion - (set-buffer (get-buffer-create " *base64-encode*")) - (erase-buffer) - (insert string) - (base64-encode-region (point-min) (point-max) no-line-break) - (skip-chars-backward " \t\r\n") - (delete-region (point-max) (point)) - (prog1 - (buffer-string) - (kill-buffer (current-buffer))))) - -(defun base64-decode (string) - (save-excursion - (set-buffer (get-buffer-create " *base64-decode*")) - (erase-buffer) - (insert string) - (base64-decode-region (point-min) (point-max)) - (goto-char (point-max)) - (skip-chars-backward " \t\r\n") - (delete-region (point-max) (point)) - (prog1 - (buffer-string) - (kill-buffer (current-buffer))))) - -(defalias 'base64-decode-string 'base64-decode) -(defalias 'base64-encode-string 'base64-encode) - -);; (static-when nil ... - -(provide 'base64) diff --git a/lisp/gnus-mh.el b/lisp/gnus-mh.el index a73e90b..0278d50 100644 --- a/lisp/gnus-mh.el +++ b/lisp/gnus-mh.el @@ -40,6 +40,9 @@ (require 'gnus-msg) (require 'gnus-sum) +(eval-when-compile + (defvar mh-lib-progs)) + (defun gnus-summary-save-article-folder (&optional arg) "Append the current article to an mh folder. If N is a positive number, save the N next articles. diff --git a/lisp/gnus-sum.el b/lisp/gnus-sum.el index 480d0ab..e1d3978 100644 --- a/lisp/gnus-sum.el +++ b/lisp/gnus-sum.el @@ -1153,6 +1153,8 @@ end position and text.") (defvar gnus-newsgroup-ephemeral-charset nil) (defvar gnus-newsgroup-ephemeral-ignored-charsets nil) +(defvar gnus-article-before-search nil) + (defconst gnus-summary-local-variables '(gnus-newsgroup-name gnus-newsgroup-begin gnus-newsgroup-end @@ -7116,10 +7118,14 @@ If BACKWARD, search backward instead." current-prefix-arg)) (if (string-equal regexp "") (setq regexp (or gnus-last-search-regexp "")) - (setq gnus-last-search-regexp regexp)) - (if (gnus-summary-search-article regexp backward) - (gnus-summary-show-thread) - (error "Search failed: \"%s\"" regexp))) + (setq gnus-last-search-regexp regexp) + (setq gnus-article-before-search gnus-current-article)) + ;; Intentionally set gnus-last-article. + (setq gnus-last-article gnus-article-before-search) + (let ((gnus-last-article gnus-last-article)) + (if (gnus-summary-search-article regexp backward) + (gnus-summary-show-thread) + (error "Search failed: \"%s\"" regexp)))) (defun gnus-summary-search-article-backward (regexp) "Search for an article containing REGEXP backward." diff --git a/lisp/gpg-ring.el b/lisp/gpg-ring.el deleted file mode 100644 index 0ac4979..0000000 --- a/lisp/gpg-ring.el +++ /dev/null @@ -1,482 +0,0 @@ -;;; gpg-ring.el --- Major mode for editing GnuPG key rings. - -;; Copyright (C) 2000 RUS-CERT, University Of Stuttgart - -;; Author: Florian Weimer -;; Maintainer: Florian Weimer -;; Keywords: crypto -;; Created: 2000-04-28 - -;; This file is NOT (yet?) 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. - - - -;;;; Code: - -(require 'gpg) -(eval-when-compile - (require 'cl)) - -;;;; Customization: - -;;; Customization: Groups: - -(defgroup gpg-ring nil - "GNU Privacy Guard user interface." - :tag "GnuPG user interface" - :group 'gpg) - -;;; Customization: Variables: - -(defface gpg-ring-key-invalid-face - '((((class color)) - (:foreground "yellow" :background "red")) - (t (:bold t :italic t :underline t))) - "Face for strings indicating key invalidity." - :group 'gpg-ring) - -(defface gpg-ring-uncertain-validity-face - '((((class color)) (:foreground "red")) - (t (:bold t))) - "Face for strings indicating uncertain validity." - :group 'gpg-ring) - -(defface gpg-ring-full-validity-face - '((((class color)) (:foreground "ForestGreen" :bold t)) - (t (:bold t))) - "Face for strings indicating key invalidity." - :group 'gpg-ring) - -(defvar gpg-ring-mode-hook nil - "Normal hook run when entering GnuPG ring mode.") - -;;; Constants - -(defconst gpg-ring-algo-alist - '((rsa . "RSA") - (rsa-encrypt-only . "RSA-E") - (rsa-sign-only . "RSA-S") - (elgamal-encrypt-only . "ELG-E") - (dsa . "DSA") - (elgamal . "ELG-E")) - "Alist mapping algorithm IDs to algorithm abbreviations.") - -(defconst gpg-ring-trust-alist - '((not-known "???" gpg-ring-uncertain-validity-face) - (disabled "DIS" gpg-ring-key-invalid-face) - (revoked "REV" gpg-ring-key-invalid-face) - (expired "EXP" gpg-ring-key-invalid-face) - (trust-undefined "QES" gpg-ring-uncertain-validity-face) - (trust-none "NON" gpg-ring-uncertain-validity-face) - (trust-marginal "MAR") - (trust-full "FUL" gpg-ring-full-validity-face) - (trust-ultimate "ULT" gpg-ring-full-validity-face)) - "Alist mapping trust IDs to trust abbrevs and faces.") - -(defvar gpg-ring-mode-map - (let ((map (make-keymap))) - (suppress-keymap map t) - map) - "Keymap for `gpg-ring-mode'.") - -(define-key gpg-ring-mode-map "0" 'delete-window) -(define-key gpg-ring-mode-map "1" 'delete-other-windows) -(define-key gpg-ring-mode-map "M" 'gpg-ring-mark-process-all) -(define-key gpg-ring-mode-map "U" 'gpg-ring-unmark-all) -(define-key gpg-ring-mode-map "a" 'gpg-ring-toggle-show-unusable) -(define-key gpg-ring-mode-map "d" 'gpg-ring-mark-delete) -(define-key gpg-ring-mode-map "f" 'gpg-ring-update-key) -(define-key gpg-ring-mode-map "g" 'gpg-ring-update) -(define-key gpg-ring-mode-map "i" 'gpg-ring-show-key) -(define-key gpg-ring-mode-map "l" 'gpg-ring-toggle-show-all-ids) -(define-key gpg-ring-mode-map "m" 'gpg-ring-mark-process) -(define-key gpg-ring-mode-map "n" 'gpg-ring-next-record) -(define-key gpg-ring-mode-map "p" 'gpg-ring-previous-record) -(define-key gpg-ring-mode-map "q" 'gpg-ring-quit) -(define-key gpg-ring-mode-map "u" 'gpg-ring-unmark) -(define-key gpg-ring-mode-map "x" 'gpg-ring-extract-keys) -(define-key gpg-ring-mode-map "X" 'gpg-ring-extract-keys-to-kill) - -(define-key gpg-ring-mode-map "\C-c\C-c" 'gpg-ring-action) - -;;; Internal functions: - -(defvar gpg-ring-key-list - nil - "List of keys in the key list buffer.") -(make-variable-buffer-local 'gpg-ring-key-list) - -(defvar gpg-ring-update-funcs - nil - "List of functions called to obtain the key list.") -(make-variable-buffer-local 'gpg-ring-update-funcs) - -(defvar gpg-ring-show-unusable - nil - "If t, show expired, revoked and disabled keys, too.") -(make-variable-buffer-local 'gpg-ring-show-unusable) - -(defvar gpg-ring-show-all-ids - nil - "If t, show all user IDs. If nil, show only the primary user ID.") -(make-variable-buffer-local 'gpg-ring-show-all-ids) - -(defvar gpg-ring-marks-alist - nil - "Alist of (UNIQUE-ID MARK KEY). -UNIQUE-ID is a unique key ID from GnuPG. MARK is either `?D' -(marked for deletion), or `?*' (marked for processing).") -(make-variable-buffer-local 'gpg-ring-marks-alist) - -(defvar gpg-ring-action - nil - "Function to call when `gpg-ring-action' is invoked. -A list of the keys which are marked for processing is passed as argument.") -(make-variable-buffer-local 'gpg-ring-action) - -(defun gpg-ring-mode () - "Mode for editing GnuPG key rings. -\\{gpg-ring-mode-map} -Turning on gpg-ring-mode runs `gpg-ring-mode-hook'." - (interactive) - (kill-all-local-variables) - (buffer-disable-undo) - (setq truncate-lines t) - (setq buffer-read-only t) - (use-local-map gpg-ring-mode-map) - (setq mode-name "Key Ring") - (setq major-mode 'gpg-ring-mode) - (run-hooks 'gpg-ring-mode-hook)) - - -(defmacro gpg-ring-record-start (&optional pos) - "Return buffer position of start of record containing POS." - `(get-text-property (or ,pos (point)) 'gpg-record-start)) - -(defun gpg-ring-current-key (&optional pos) - "Return GnuPG key at POS, or at point if ommitted." - (or (get-text-property (or pos (point)) 'gpg-key) - (error "No record on current line"))) - -(defun gpg-ring-goto-record (pos) - "Go to record starting at POS. -Position point after the marks at the beginning of a record." - (goto-char pos) - (forward-char 2)) - -(defun gpg-ring-next-record () - "Advances point to the start of the next record." - (interactive) - (let ((start (next-single-property-change - (point) 'gpg-record-start nil (point-max)))) - ;; Don't advance to the last line of the buffer. - (when (/= start (point-max)) - (gpg-ring-goto-record start)))) - -(defun gpg-ring-previous-record () - "Advances point to the start of the previous record." - (interactive) - ;; The last line of the buffer doesn't contain a record. - (let ((start (gpg-ring-record-start))) - (if start - (gpg-ring-goto-record (previous-single-property-change - start 'gpg-record-start nil (point-min))) - (gpg-ring-goto-record - (gpg-ring-record-start (1- (point-max))))))) - -(defun gpg-ring-set-mark (&optional pos mark) - "Set MARK on record at POS, or at point if POS is omitted. -If MARK is omitted, clear it." - (save-excursion - (let* ((start (gpg-ring-record-start pos)) - (key (gpg-ring-current-key start)) - (id (gpg-key-unique-id key)) - (entry (assoc id gpg-ring-marks-alist)) - buffer-read-only) - (goto-char start) - ;; Replace the mark character. - (subst-char-in-region (point) (1+ (point)) (char-after) - (or mark ? )) - ;; Store the mark in alist. - (if entry - (setcdr entry (if mark (list mark key))) - (when mark - (push (list id mark key) gpg-ring-marks-alist)))))) - -(defun gpg-ring-marked-keys (&optional only-marked mark) - "Return list of key specs which have MARK. -If no marks are present and ONLY-MARKED is not nil, return singleton -list with key of the current record. If MARK is omitted, `?*' is -used." - (let ((the-marker (or mark ?*)) - (marks gpg-ring-marks-alist) - key-list) - (while marks - (let ((mark (pop marks))) - ;; If this entry has got the right mark ... - (when (equal (nth 1 mark) the-marker) - ;; ... rember the key spec. - (push (nth 2 mark) key-list)))) - (or key-list (if (not only-marked) (list (gpg-ring-current-key)))))) - -(defun gpg-ring-mark-process () - "Mark record at point for processing." - (interactive) - (gpg-ring-set-mark nil ?*) - (gpg-ring-next-record)) - -(defun gpg-ring-mark-delete () - "Mark record at point for processing." - (interactive) - (gpg-ring-set-mark nil ?D) - (gpg-ring-next-record)) - -(defun gpg-ring-unmark () - "Mark record at point for processing." - (interactive) - (gpg-ring-set-mark) - (gpg-ring-next-record)) - -(defun gpg-ring-mark-process-all () - "Put process mark on all records." - (interactive) - (setq gpg-ring-marks-alist - (mapcar (lambda (key) - (list (gpg-key-unique-id key) ?* key)) - gpg-ring-key-list)) - (gpg-ring-regenerate)) - -(defun gpg-ring-unmark-all () - "Remove all record marks." - (interactive) - (setq gpg-ring-marks-alist nil) - (gpg-ring-regenerate)) - -(defun gpg-ring-toggle-show-unusable () - "Toggle value if `gpg-ring-show-unusable'." - (interactive) - (setq gpg-ring-show-unusable (not gpg-ring-show-unusable)) - (gpg-ring-regenerate)) - -(defun gpg-ring-toggle-show-all-ids () - "Toggle value of `gpg-ring-show-all-ids'." - (interactive) - (setq gpg-ring-show-all-ids (not gpg-ring-show-all-ids)) - (gpg-ring-regenerate)) - -(defvar gpg-ring-output-buffer-name "*GnuPG Output*" - "Name buffer to which output from GnuPG is sent.") - -(defmacro gpg-ring-with-output-buffer (&rest body) - "Erase GnuPG output buffer, evaluate BODY in it, and display it." - `(with-current-buffer (get-buffer-create gpg-ring-output-buffer-name) - (erase-buffer) - (setq truncate-lines t) - ,@body - (goto-char (point-min)) - (display-buffer gpg-ring-output-buffer-name))) - -(defun gpg-ring-quit () - "Bury key list buffer and kill GnuPG output buffer." - (interactive) - (let ((output (get-buffer gpg-ring-output-buffer-name))) - (when output - (kill-buffer output))) - (when (eq 'gpg-ring-mode major-mode) - (bury-buffer))) - -(defun gpg-ring-show-key () - "Show information for current key." - (interactive) - (let ((keys (gpg-ring-marked-keys))) - (gpg-ring-with-output-buffer - (gpg-key-insert-information (gpg-key-unique-id-list keys))))) - -(defun gpg-ring-extract-keys () - "Export currently selected public keys in ASCII armor." - (interactive) - (let ((keys (gpg-ring-marked-keys))) - (gpg-ring-with-output-buffer - (gpg-key-insert-public-key (gpg-key-unique-id-list keys))))) - -(defun gpg-ring-extract-keys-to-kill () - "Export currently selected public keys in ASCII armor to kill ring." - (interactive) - (let ((keys (gpg-ring-marked-keys))) - (with-temp-buffer - (gpg-key-insert-public-key (gpg-key-unique-id-list keys)) - (copy-region-as-kill (point-min) (point-max))))) - -(defun gpg-ring-update-key () - "Fetch key information from key server." - (interactive) - (let ((keys (gpg-ring-marked-keys))) - (gpg-ring-with-output-buffer - (gpg-key-retrieve (gpg-key-unique-id-list keys))))) - -(defun gpg-ring-insert-key-stat (key) - (let* ((validity (gpg-key-validity key)) - (validity-entry (assq validity gpg-ring-trust-alist)) - (trust (gpg-key-trust key)) - (trust-entry (assq trust gpg-ring-trust-alist))) - ;; Insert abbrev for key status. - (let ((start (point))) - (insert (nth 1 validity-entry)) - ;; Change face if necessary. - (when (nth 2 validity-entry) - (add-text-properties start (point) - (list 'face (nth 2 validity-entry))))) - ;; Trust, key ID, length, algorithm, creation date. - (insert (format "/%s %-8s/%4d/%-5s created %s" - (nth 1 trust-entry) - (gpg-short-key-id key) - (gpg-key-length key) - (cdr (assq (gpg-key-algorithm key) gpg-ring-algo-alist)) - (gpg-key-creation-date key))) - ;; Expire date. - (when (gpg-key-expire-date key) - (insert ", ") - (let ((start (point)) - (expired (eq 'expired validity)) - (notice (concat ))) - (insert (if expired "EXPIRED" "expires") - " " (gpg-key-expire-date key)) - (when expired - (add-text-properties start (point) - '(face gpg-ring-key-invalid-face))))))) - -(defun gpg-ring-insert-key (key &optional mark) - "Inserts description for KEY into current buffer before point." - (let ((start (point))) - (insert (if mark mark " ") - " " (gpg-key-primary-user-id key) "\n" - " ") - (gpg-ring-insert-key-stat key) - (insert "\n") - (when gpg-ring-show-all-ids - (let ((uids (gpg-key-user-ids key))) - (while uids - (insert " ID " (pop uids) "\n")))) - (add-text-properties start (point) - (list 'gpg-record-start start - 'gpg-key key)))) - -(defun gpg-ring-regenerate () - "Regenerate the key list buffer from stored data." - (interactive) - (let* ((key-list gpg-ring-key-list) - ;; Record position of point. - (old-record (if (eobp) ; No record on last line. - nil - (gpg-key-unique-id (gpg-ring-current-key)))) - (old-pos (if old-record (- (point) (gpg-ring-record-start)))) - found new-pos new-pos-offset buffer-read-only new-marks) - ;; Replace buffer contents with new data. - (erase-buffer) - (while key-list - (let* ((key (pop key-list)) - (id (gpg-key-unique-id key)) - (mark (assoc id gpg-ring-marks-alist))) - (when (or gpg-ring-show-unusable - (not (memq (gpg-key-validity key) - '(disabled revoked expired)))) - ;; Check if point was in this record. - (when (and old-record - (string-equal old-record id)) - (setq new-pos (point)) - (setq new-pos-offset (+ new-pos old-pos))) - ;; Check if this record was marked. - (if (nth 1 mark) - (progn - (push mark new-marks) - (gpg-ring-insert-key key (nth 1 mark))) - (gpg-ring-insert-key key))))) - ;; Replace mark alist with the new one (which does not contain - ;; marks for records which vanished during this update). - (setq gpg-ring-marks-alist new-marks) - ;; Restore point. - (if (not old-record) - ;; We were at the end of the buffer before. - (goto-char (point-max)) - (if new-pos - (if (and (< new-pos-offset (point-max)) - (equal old-record (gpg-key-unique-id - (gpg-ring-current-key new-pos-offset)))) - ;; Record is there, with offset. - (goto-char new-pos-offset) - ;; Record is there, but not offset. - (goto-char new-pos)) - ;; Record is not there. - (goto-char (point-min)))))) - -(defun gpg-ring-update () - "Update the key list buffer with new data." - (interactive) - (let ((funcs gpg-ring-update-funcs) - old) - ;; Merge the sorted lists obtained by calling elements of - ;; `gpg-ring-update-funcs'. - (while funcs - (let ((additional (funcall (pop funcs))) - new) - (while (and additional old) - (if (gpg-key-lessp (car additional) (car old)) - (push (pop additional) new) - (if (gpg-key-lessp (car old) (car additional)) - (push (pop old) new) - ;; Keys are perhaps equal. Always Add old key. - (push (pop old) new) - ;; If new key is equal, drop it, otherwise add it as well. - (if (string-equal (gpg-key-unique-id (car old)) - (gpg-key-unique-id (car additional))) - (pop additional) - (push (pop additional) new))))) - ;; Store new list as old one for next round. - (setq old (nconc (nreverse new) old additional)))) - ;; Store the list in the buffer. - (setq gpg-ring-key-list old)) - (gpg-ring-regenerate)) - -(defun gpg-ring-action () - "Perform the action associated with this buffer." - (interactive) - (if gpg-ring-action - (funcall gpg-ring-action (gpg-ring-marked-keys)) - (error "No action for this buffer specified"))) - -;;;###autoload -(defun gpg-ring-keys (&optional key-list-funcs action) - (interactive) - (let ((buffer (get-buffer-create "*GnuPG Key List*"))) - (with-current-buffer buffer - (gpg-ring-mode) - (setq gpg-ring-action action) - (setq gpg-ring-update-funcs key-list-funcs key-list-funcs) - (gpg-ring-update) - (goto-char (point-min))) - (switch-to-buffer buffer))) - -;;;###autoload -(defun gpg-ring-public (key-spec) - "List public keys matching keys KEY-SPEC." - (interactive "sList public keys containing: ") - (gpg-ring-keys `((lambda () (gpg-key-list-keys ,key-spec))))) - -(provide 'gpg-ring) - -;;; gpg-ring.el ends here \ No newline at end of file diff --git a/lisp/gpg.el b/lisp/gpg.el deleted file mode 100644 index b883c46..0000000 --- a/lisp/gpg.el +++ /dev/null @@ -1,1235 +0,0 @@ -;;; gpg.el --- Interface to GNU Privacy Guard - -;; Copyright (C) 2000 RUS-CERT, University Of Stuttgart - -;; Author: Florian Weimer -;; Maintainer: Florian Weimer -;; Keywords: crypto -;; Created: 2000-04-15 - -;; This file is NOT (yet?) 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: - -;; ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA -;; ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA -;; -;; This code is not well-tested. BE CAREFUL! -;; -;; ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA -;; ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA ALPHA - -;; Implemented features which can be tested: -;; -;; * Customization for all flavors of PGP is possible. -;; * The main operations (verify, decrypt, sign, encrypt, sign & -;; encrypt) are implemented. -;; * Gero Treuner's gpg-2comp script is supported, and data which is is -;; compatible with PGP 2.6.3 is generated. - -;; Customizing external programs -;; ============================= - -;; The customization are very similar to those of others programs, -;; only the C-ish "%" constructs have been replaced by more Lisp-like -;; syntax. -;; -;; First, you have to adjust the default executable paths -;; (`gpg-command-default-alist', customization group `gpg-options', -;; "Controlling GnuPG invocation."). After that, you should -;; change the configuration options which control how specific -;; command line flags are built (`gpg-command-flag-sign-with-key', -;; (`gpg-command-flag-recipient'). The elements of these lists are -;; concatenated without spaces, and a new argument is only started -;; where indicated. The `gpg-command-flag-recipient' list is special: -;; it consists of two parts, the first one remains at the beginning -;; of the argument, the second one is repeated for each recipient. -;; Finally, `gpg-command-passphrase-env' has to be changed if there's -;; no command line flag to force the external program to read the data -;; from standard input before the message. -;; -;; In customization group `gpg-commands', "Controlling GnuPG -;; invocation.", you have to supply the actual syntax for external -;; program calls. Each variable consists of a pair of a program -;; specification (if a Lisp symbol is given here, it is translated -;; via `gpg-command-default-alist') and a list of program arguments -;; with placeholders. Please read the documentation of each variable -;; before making your adjustments and try to match the given -;; requirements as closely as possible! -;; -;; The `gpg-commands-key' group, "GnuPG Key Management Commands.", -;; specifies key management commands. The syntax of these variables -;; is like those in the `gpg-commands' group. Note that the output -;; format of some of these external programs has to match very close -;; that of GnuPG. Additional tools (Thomas Roessler's "pgpring.c") -;; are available if your favorite implementation of OpenPGP cannot -;; output the this format. - -;; Security considerations -;; ======================= - -;; On a typical multiuser UNIX system, the memory image of the -;; Emacs process is not locked, therefore it can be swapped to disk -;; at any time. As a result, the passphrase might show up in the -;; swap space (even if you don't use the passphrase cache, i.e. if -;; `gpg-passphrase-timeout' is 0). If someone is able to run `gdb' or -;; another debugger on your Emacs process, he might be able to recover -;; the passphrase as well. Unfortunately, nothing can be done in -;; order to prevent this at the moment. -;; -;; BE CAREFUL: If you use the passphrase cache feature, the passphrase -;; is stored in the variable `gpg-passphrase' -- and it is NOT -;; encrypted in any way. (This is a conceptual problem because the -;; nature of the passphrase cache requires that Emacs is able to -;; decrypt automatically, so only a very weak protection could be -;; applied anyway.) -;; -;; In addition, if you use an unpatched Emacs 20 (and earlier -;; versions), passwords show up in the output of the `view-lossage' -;; function (bound to `C-h l' by default). - - -;;;; Code: - -(require 'timer) -(eval-when-compile - (require 'cl)) - -;;;; Customization: - -;;; Customization: Groups: - -(defgroup gpg nil - "GNU Privacy Guard interface." - :tag "GnuPG" - :group 'processes) - -(defgroup gpg-options nil - "Controlling GnuPG invocation." - :tag "GnuPG Options" - :group 'gpg) - -(defgroup gpg-commands nil - "Primary GnuPG Operations." - :tag "GnuPG Commands" - :group 'gpg) - -(defgroup gpg-commands-key nil - "Commands for GnuPG key management." - :tag "GnuPG Key Commands" - :group 'gpg-commands) - -;;; Customization: Widgets: - -(define-widget 'gpg-command-alist 'alist - "An association list for GnuPG command names." - :key-type '(symbol :tag "Abbreviation") - :value-type '(string :tag "Program name") - :convert-widget 'widget-alist-convert-widget - :tag "Alist") - -(define-widget 'gpg-command-program 'choice - "Widget for entering the name of a program (mostly the GnuPG binary)." - :tag "Program" - :args '((const :tag "Default GnuPG program." - :value gpg) - (const :tag "GnuPG compatibility wrapper." - :value gpg-2comp) - (const :tag "Disabled" - :value nil) - (string :tag "Custom program" :format "%v"))) - -(define-widget 'gpg-command-sign-options 'cons - "Widget for entering signing options." - :args '(gpg-command-program - (repeat - :tag "Arguments" - (choice - :format "%[Type%] %v" - (const :tag "Insert armor option here if necessary." - :value armor) - (const :tag "Insert text mode option here if necessary." - :value textmode) - (const :tag "Insert the sign with key option here if necessary." - :value sign-with-key) - (string :format "%v"))))) - -(define-widget 'gpg-command-key-options 'cons - "Widget for entering key command options." - :args '(gpg-command-program - (repeat - :tag "Arguments" - (choice - :format "%[Type%] %v" - (const :tag "Insert key ID here." - :value key-id) - (string :format "%v"))))) - -;;; Customization: Variables: - -;;; Customization: Variables: Paths and Flags: - -(defcustom gpg-passphrase-timeout - 0 - "Timeout (in seconds) for the passphrase cache. -The passphrase cache is cleared after is hasn't been used for this -many seconds. The values 0 means that the passphrase is not cached at -all." - :tag "Passphrase Timeout" - :type 'number - :group 'gpg-options) - -(defcustom gpg-default-key-id - nil - "Default key/user ID used for signatures." - :tag "Default Key ID" - :type '(choice - (const :tag "Use GnuPG default." :value nil) - (string)) - :group 'gpg-options) - -(defcustom gpg-temp-directory - (expand-file-name "~/tmp") - "Directory for temporary files. -If you are running Emacs 20, this directory must have mode 0700." - :tag "Temp directory" - :type 'string - :group 'gpg-options) - -(defcustom gpg-command-default-alist - '((gpg . "gpg") - (gpg-2comp . "gpg-2comp")) - "Default paths for some GnuPG-related programs. -Modify this variable if you have to change the paths to the -executables required by the GnuPG interface. You can enter \"gpg\" -for `gpg-2comp' if you don't have this script, but you'll lose PGP -2.6.x compatibility." - :tag "GnuPG programs" - :type 'gpg-command-alist - :group 'gpg-options) - -(defcustom gpg-command-flag-textmode "--textmode" - "The flag to indicate canonical text mode to GnuPG." - :tag "Text mode flag" - :type 'string - :group 'gpg-options) - -(defcustom gpg-command-flag-armor "--armor" - "The flag to request ASCII-armoring output from GnuPG." - :tag "Armor flag" - :type 'string - :group 'gpg-options) - -(defcustom gpg-command-flag-sign-with-key '("--local-user=" sign-with-key) - "String to include to specify the signing key ID. -The elements are concatenated (without spaces) to form a command line -option." - :tag "Sign with key flag" - :type '(repeat :tag "Argument parts" - (choice :format "%[Type%] %v" - (const :tag "Start next argument." :value next-argument) - (const :tag "Insert signing key ID here." :value sign-with-key) - (string))) - :group 'gpg-options) - -(defcustom gpg-command-flag-recipient - '(nil . ("-r" next-argument recipient next-argument)) - "Format of a recipient specification. -The elements are concatenated (without spaces) to form a command line -option. The second part is repeated for each recipient." - :tag "Recipients Flag" - :type '(cons - (repeat :tag "Common prefix" - (choice :format "%[Type%] %v" - (const :tag "Start next argument." :value next-argument) - (string))) - (repeat :tag "For each recipient" - (choice :format "%[Type%] %v" - (const :tag "Start next argument." :value next-argument) - (const :tag "Insert recipient key ID here." :value recipient) - (string)))) - :group 'gpg-options) - -(defcustom gpg-command-passphrase-env - nil - "Environment variable to set when a passphrase is required, or nil. -If an operation is invoked which requires a passphrase, this -environment variable is set before calling the external program to -indicate that it should read the passphrase from standard input." - :tag "Passphrase environment" - :type '(choice - (const :tag "Disabled" :value nil) - (cons - (string :tag "Variable") - (string :tag "Value"))) - :group 'gpg-options) - -;;; Customization: Variables: GnuPG Commands: - -(defcustom gpg-command-verify - '(gpg . ("--batch" "--verbose" "--verify" signature-file message-file)) - "Command to verify a detached signature. -The invoked program has to read the signed message and the signature -from the given files. It should write human-readable information to -standard output and/or standard error. The program shall not convert -charsets or line endings; the input data shall be treated as binary." - :tag "Verify Command" - :type '(cons - gpg-command-program - (repeat - :tag "Arguments" - (choice - :format "%[Type%] %v" - (const :tag "Insert name of file containing the message here." - :value message-file) - (const :tag "Insert name of file containing the signature here." - :value signature-file) - (string :format "%v")))) - :group 'gpg-commands) - -(defcustom gpg-command-decrypt - '(gpg . ("--decrypt" "--batch" "--passphrase-fd=0")) - "Command to decrypt a message. -The invoked program has to read the passphrase from standard -input, followed by the encrypted message. It writes the decrypted -message to standard output, and human-readable diagnostic messages to -standard error." - :tag "Decrypt Command" - :type '(cons - gpg-command-program - (repeat - :tag "Arguments" - (choice - :format "%[Type%] %v" - (const :tag "Insert name of file containing the message here." - :value message-file) - (string :format "%v")))) - :group 'gpg-commands) - -(defcustom gpg-command-sign-cleartext - '(gpg-2comp . ("--batch" "--passphrase-fd=0" "--output=-" - armor textmode "--clearsign" - sign-with-key)) - "Command to create a create a \"clearsign\" text file. -The invoked program has to read the passphrase from standard input, -followed by the message to sign. It should write the ASCII-amored -signed text message to standard output, and diagnostic messages to -standard error." - :tag "Clearsign Command" - :type 'gpg-command-sign-options - :group 'gpg-commands) - -(defcustom gpg-command-sign-detached - '(gpg-2comp . ("--batch" "--passphrase-fd=0" "--output=-" - armor textmode "--detach-sign" - sign-with-key)) - "Command to create a create a detached signature. -The invoked program has to read the passphrase from standard input, -followed by the message to sign. It should write the ASCII-amored -detached signature to standard output, and diagnostic messages to -standard error. The program shall not convert charsets or line -endings; the input data shall be treated as binary." - :tag "Sign Detached Command" - :type 'gpg-command-sign-options - :group 'gpg-commands) - -(defcustom gpg-command-sign-encrypt - '(gpg-2comp . ("--batch" "--passphrase-fd=0" "--output=-" - armor textmode "--always-trust" sign-with-key recipients - "--sign" "--encrypt" plaintext-file)) - "Command to sign and encrypt a file. -The invoked program has to read the passphrase from standard input, -followed by the message to sign and encrypt if there is no -`plaintext-file' placeholder. It should write the ASCII-amored -encrypted message to standard output, and diagnostic messages to -standard error." - :tag "Sign And Encrypt Command" - :type '(cons - gpg-command-program - (repeat - :tag "Arguments" - (choice - :format "%[Type%] %v" - (const :tag "Insert the `sign with key' option here if necessary." - :value sign-with-key) - (const :tag "Insert list of recipients here." - :value recipients) - (const :tag "Insert here name of file with plaintext." - :value plaintext-file) - (string :format "%v")))) - :group 'gpg-commands) - -(defcustom gpg-command-encrypt - '(gpg-2comp . ("--batch" "--output=-" armor textmode "--always-trust" - "--encrypt" recipients plaintext-file)) - "Command to encrypt a file. -The invoked program has to read the message to encrypt from standard -input or from the plaintext file (if the `plaintext-file' placeholder -is present). It should write the ASCII-amored encrypted message to -standard output, and diagnostic messages to standard error." - :type '(cons - gpg-command-program - (repeat - :tag "Arguments" - (choice - :format "%[Type%] %v" - (const :tag "Insert list of recipients here." - :value recipients) - (const :tag "Insert here name of file with plaintext." - :value plaintext-file) - (string :format "%v")))) - :group 'gpg-commands) - -;;; Customization: Variables: Key Management Commands: - -(defcustom gpg-command-key-import - '(gpg . ("--import" "--verbose" message-file)) - "Command to import a public key from a file." - :tag "Import Command" - :type '(cons - gpg-command-program - (repeat - :tag "Arguments" - (choice - :format "%[Type%] %v" - (const :tag "Insert name of file containing the key here." - :value message-file) - (string :format "%v")))) - :group 'gpg-commands-key) - -(defcustom gpg-command-key-export - '(gpg . ("--no-verbose" "--armor" "--export" key-id)) - "Command to export a public key from the key ring. -The key should be written to standard output using ASCII armor." - :tag "Export Command" - :type 'gpg-command-key-options - :group 'gpg-commands-key) - -(defcustom gpg-command-key-verify - '(gpg . ("--no-verbose" "--batch" "--fingerprint" "--check-sigs" key-id)) - "Command to verify a public key." - :tag "Verification Command" - :type 'gpg-command-key-options - :group 'gpg-commands-key) - -(defcustom gpg-command-key-public-ring - '(gpg . ("--no-verbose" "--batch" "--with-colons" "--list-keys" key-id)) - "Command to list the contents of the public key ring." - :tag "List Public Key Ring Command" - :type 'gpg-command-key-options - :group 'gpg-commands-key) - -(defcustom gpg-command-key-secret-ring - '(gpg . ("--no-verbose" "--batch" "--with-colons" - "--list-secret-keys" key-id)) - "Command to list the contents of the secret key ring." - :tag "List Secret Key Ring Command" - :type 'gpg-command-key-options - :group 'gpg-commands-key) - -(defcustom gpg-command-key-retrieve - '(gpg . ("--batch" "--recv-keys" key-id)) - "Command to retrieve public keys." - :tag "Retrieve Keys Command" - :type 'gpg-command-key-options - :group 'gpg-commands-key) - - -;;;; Helper functions for GnuPG invocation: - -;;; Build the GnuPG command line: - -(defun gpg-build-argument (template substitutions &optional pass-start) - "Build command line argument(s) by substituting placeholders. -TEMPLATE is a list of strings and symbols. The placeholder symbols in -it are replaced by SUBSTITUTIONS, the elements between -`next-argument' symbols are concatenated without spaces and are -returned in a list. - -SUBSTITIONS is a list of (SYMBOL . SEXP) pairs, where SEXP is either -a string (which is inserted literally), a list of strings (which are -inserted as well), or nil, which means to insert nothing. - -If PASS-START is t, `next-argument' is also inserted into the result, -and symbols without a proper substitution are retained in the output, -otherwise, an untranslated symbol results in an error. - -This function does not handle empty arguments reliably." - (let ((current-arg "") - (arglist nil)) - (while template - (let* ((templ (pop template)) - (repl (assoc templ substitutions)) - (new (if repl (cdr repl) templ))) - (cond - ((eq templ 'next-argument) - ;; If the current argument is not empty, start a new one. - (unless (equal current-arg "") - (setq arglist (nconc arglist - (if pass-start - (list current-arg 'next-argument) - (list current-arg)))) - (setq current-arg ""))) - ((null new) nil) ; Drop it. - ((and (not (stringp templ)) (null repl)) - ;; Retain an untranslated symbol in the output if - ;; `pass-start' is true. - (unless pass-start - (error "No replacement for `%s'" templ)) - (setq arglist (nconc arglist (list current-arg templ))) - (setq current-arg "")) - (t - (unless (listp new) - (setq new (list new))) - (setq current-arg (concat current-arg - (apply 'concat new))))))) - (unless (equal current-arg "") - (setq arglist (nconc arglist (list current-arg)))) - arglist)) - -(defun gpg-build-arg-list (template substitutions) - "Build command line by substituting placeholders. -TEMPLATE is a list of strings and symbols. The placeholder symbols in -it are replaced by SUBSTITUTIONS. - -SUBSTITIONS is a list of (SYMBOL . SEXP) pairs, where SEXP is either a -string (which is inserted literally), a list of strings (which are -inserted as well), or nil, which means to insert nothing." - (let (arglist) - (while template - (let* ((templ (pop template)) - (repl (assoc templ substitutions)) - (new (if repl (cdr repl) templ))) - (cond - ((and (symbolp templ) (null repl)) - (error "No replacement for `%s'" templ)) - ((null new) nil) ; Drop it. - (t - (unless (listp new) - (setq new (list new))) - (setq arglist (nconc arglist new)))))) - arglist)) - -(defun gpg-build-flag-recipients-one (recipient) - "Build argument for one RECIPIENT." - (gpg-build-argument (cdr gpg-command-flag-recipient) - `((recipient . ,recipient)) t)) - -(defun gpg-build-flag-recipients (recipients) - "Build list of RECIPIENTS using `gpg-command-flag-recipient'." - (gpg-build-argument - (apply 'append (car gpg-command-flag-recipient) - (mapcar 'gpg-build-flag-recipients-one - recipients)) - nil)) - -(defun gpg-read-recipients () - "Query the user for several recipients." - (let ((go t) - recipients r) - (while go - (setq r (read-string "Enter recipient ID [RET when no more]: ")) - (if (equal r "") - (setq go nil) - (setq recipients (nconc recipients (list r))))) - recipients)) - -(defun gpg-build-flag-sign-with-key (key) - "Build sign with key flag using `gpg-command-flag-sign-with-key'." - (let ((k (if key key - (if gpg-default-key-id gpg-default-key-id - nil)))) - (if k - (gpg-build-argument gpg-command-flag-sign-with-key - (list (cons 'sign-with-key k))) - nil))) - -(defmacro gpg-with-passphrase-env (&rest body) - "Adjust the process environment and evaluate BODY. -During the evaluation of the body forms, the process environment is -adjust according to `gpg-command-passphrase-env'." - (let ((env-value (make-symbol "env-value"))) - `(let ((,env-value)) - (unwind-protect - (progn - (when gpg-command-passphrase-env - (setq ,env-value (getenv (car gpg-command-passphrase-env))) - (setenv (car gpg-command-passphrase-env) - (cdr gpg-command-passphrase-env))) - ,@body) - (when gpg-command-passphrase-env - ;; This will clear the variable if it wasn't set before. - (setenv (car gpg-command-passphrase-env) ,env-value)))))) - -;;; Temporary files: - -(defun gpg-make-temp-file () - "Create a temporary file in a safe way" - (let ((name (concat gpg-temp-directory "/gnupg"))) - (if (fboundp 'make-temp-file) - ;; If we've got make-temp-file, we are on the save side. - (make-temp-file name) - ;; make-temp-name doesn't create the file, and an ordinary - ;; write-file operation is prone to nasty symlink attacks if the - ;; temporary file resides in a world-writable directory. - (unless (eq (file-modes gpg-temp-directory) 448) ; mode 0700 - (error "Directory for temporary files must have mode 0700.")) - (setq name (make-temp-name name)) - (let ((mode (default-file-modes))) - (unwind-protect - (progn - (set-default-file-modes 384) ; mode 0600 - (with-temp-file name)) - (set-default-file-modes mode))) - name))) - -(defvar gpg-temp-files nil - "List of temporary files used by the GnuPG interface. -Do not set this variable. Call `gpg-with-temp-files' if you need -temporary files.") - -(defun gpg-with-temp-files-create (count) - "Do not call this function. Used internally by `gpg-with-temp-files'." - (while (> count 0) - (setq gpg-temp-files (cons (gpg-make-temp-file) gpg-temp-files)) - (setq count (1- count)))) - -(defun gpg-with-temp-files-delete () - "Do not call this function. Used internally by `gpg-with-temp-files'." - (while gpg-temp-files - (let ((file (pop gpg-temp-files))) - (condition-case nil - (delete-file file) - (error nil))))) - -(defmacro gpg-with-temp-files (count &rest body) - "Create COUNT temporary files, USE them, and delete them. -The function USE is called with the names of all temporary files as -arguments." - `(let ((gpg-temp-files)) - (unwind-protect - (progn - ;; Create the temporary files. - (gpg-with-temp-files-create ,count) - ,@body) - (gpg-with-temp-files-delete)))) - -;;; Making subprocesses: - -(defun gpg-exec-path (option) - "Return the program name for OPTION. -OPTION is of the form (PROGRAM . ARGLIST). This functions returns -PROGRAM, but takes default values into account." - (let* ((prg (car option)) - (path (assq prg gpg-command-default-alist))) - (cond - (path (if (null (cdr path)) - (error "Command `%s' is not available" prg) - (cdr path))) - ((null prg) (error "Command is disabled")) - (t prg)))) - -(defun gpg-call-process (cmd args stdin stdout stderr &optional passphrase) - "Invoke external program CMD with ARGS on buffer STDIN. -Standard output is insert before point in STDOUT, standard error in -STDERR. If PASSPHRASE is given, send it before STDIN. PASSPHRASE -should not end with a line feed (\"\\n\"). - -If `stdin-file' is present in ARGS, it is replaced by the name of a -temporary file. Before invoking CMD, the contents of STDIN is written -to this file." - (gpg-with-temp-files 2 - (let* ((coding-system-for-read 'no-conversion) - (coding-system-for-write 'no-conversion) - (have-stdin-file (memq 'stdin-file args)) - (stdin-file (nth 0 gpg-temp-files)) - (stderr-file (nth 1 gpg-temp-files)) - (cpr-args `(,cmd - nil ; don't delete - (,stdout ,stderr-file) - nil ; don't display - ;; Replace `stdin-file'. - ,@(gpg-build-arg-list - args (list (cons 'stdin-file stdin-file))))) - res) - (when have-stdin-file - (with-temp-file stdin-file - (buffer-disable-undo) - (insert-buffer-substring stdin))) - (setq res - (if passphrase - (with-temp-buffer - (buffer-disable-undo) - (insert passphrase "\n") - (unless have-stdin-file - (apply 'insert-buffer-substring - (if (listp stdin) stdin (list stdin)))) - (apply 'call-process-region (point-min) (point-max) cpr-args) - ;; Wipe out passphrase. - (goto-char (point-min)) - (translate-region (point) (line-end-position) - (make-string 256 ? ))) - (if (listp stdin) - (with-current-buffer (car stdin) - (apply 'call-process-region - (cadr stdin) - (if have-stdin-file (cadr stdin) (caddr stdin)) - cpr-args)) - (with-current-buffer stdin - (apply 'call-process-region - (point-min) - (if have-stdin-file (point-min) (point-max)) - cpr-args))))) - (with-current-buffer stderr - (insert-file-contents-literally stderr-file)) - (if (or (stringp res) (> res 0)) - ;; Signal or abnormal exit. - (with-current-buffer stderr - (goto-char (point-max)) - (insert (format "\nCommand exit status: %s\n" res)) - nil) - t)))) - -(defvar gpg-result-buffer nil - "The result of a GnuPG operation is stored in this buffer. -Never set this variable directly, use `gpg-show-result' instead.") - -(defun gpg-show-result-buffer (always-show result) - "Called by `gpg-show-results' to actually show the buffer." - (with-current-buffer gpg-result-buffer - ;; Only proceed if the buffer is non-empty. - (when (and (/= (point-min) (point-max)) - (or always-show (not result))) - (save-window-excursion - (display-buffer (current-buffer)) - (unless (y-or-n-p "Continue? ") - (error "GnuPG operation aborted.")))))) - -(defmacro gpg-show-result (always-show &rest body) - "Show GnuPG result to user for confirmation. -This macro binds `gpg-result-buffer' to a temporary buffer and -evaluates BODY, like `progn'. If BODY evaluates to `nil' (or -`always-show' is not nil), the user is asked for confirmation." - `(let ((gpg-result-buffer (get-buffer-create - (generate-new-buffer-name "*GnuPG Output*")))) - (unwind-protect - (gpg-show-result-buffer ,always-show (progn ,@body)) - (kill-buffer gpg-result-buffer)))) - -;;; Passphrase handling: - -(defvar gpg-passphrase-timer - (timer-create) - "This timer will clear the passphrase cache periodically.") - -(defvar gpg-passphrase - nil - "The (unencrypted) passphrase cache.") - -(defun gpg-passphrase-clear-string (str) - "Erases STR by overwriting all characters." - (let ((pos 0) - (len (length str))) - (while (< pos len) - (aset str pos ? ) - (incf pos)))) - -;;;###autoload -(defun gpg-passphrase-forget () - "Forget stored passphrase." - (interactive) - (cancel-timer gpg-passphrase-timer) - (gpg-passphrase-clear-string gpg-passphrase) - (setq gpg-passphrase nil)) - -(defun gpg-passphrase-store (passphrase) - "Store PASSPHRASE in cache. -Updates the timeout for clearing the cache to `gpg-passphrase-timeout'." - (unless (equal gpg-passphrase-timeout 0) - (timer-set-time gpg-passphrase-timer - (timer-relative-time (current-time) - gpg-passphrase-timeout)) - (timer-set-function gpg-passphrase-timer 'gpg-passphrase-forget) - (timer-activate gpg-passphrase-timer) - (setq gpg-passphrase passphrase)) - passphrase) - -(defun gpg-passphrase-read () - "Read a passphrase and remember it for some time." - (interactive) - (if gpg-passphrase - ;; This reinitializes the timer. - (gpg-passphrase-store gpg-passphrase) - (let ((pp (read-passwd "Enter passphrase: "))) - (gpg-passphrase-store pp)))) - - -;;;; Main operations: - -;;;###autoload -(defun gpg-verify (message signature result) - "Verify buffer MESSAGE against detached SIGNATURE buffer. -Returns t if everything worked out well, nil otherwise. Consult -buffer RESULT for details." - (interactive "bBuffer containing message: \nbBuffer containing signature: \nbBuffor for result: ") - (gpg-with-temp-files 2 - (let* ((sig-file (nth 0 gpg-temp-files)) - (msg-file (nth 1 gpg-temp-files)) - (cmd (gpg-exec-path gpg-command-verify)) - (args (gpg-build-arg-list (cdr gpg-command-verify) - `((signature-file . ,sig-file) - (message-file . ,msg-file)))) - res) - (with-temp-file sig-file - (buffer-disable-undo) - (apply 'insert-buffer-substring (if (listp signature) - signature - (list signature)))) - (with-temp-file msg-file - (buffer-disable-undo) - (apply 'insert-buffer-substring (if (listp message) - message - (list message)))) - (setq res (apply 'call-process-region - (point-min) (point-min) ; no data - cmd - nil ; don't delete - result - nil ; don't display - args)) - (if (or (stringp res) (> res 0)) - ;; Signal or abnormal exit. - (with-current-buffer result - (insert (format "\nCommand exit status: %s\n" res)) - nil) - t)))) - -;;;###autoload -(defun gpg-decrypt (ciphertext plaintext result &optional passphrase) - "Decrypt buffer CIPHERTEXT to buffer PLAINTEXT. -Returns t if everything worked out well, nil otherwise. Consult -buffer RESULT for details. Reads a missing PASSPHRASE using -`gpg-passphrase-read'." - (interactive "bBuffer containing ciphertext: \nbBuffer for plaintext: \nbBuffor for decryption status: ") - (gpg-call-process (gpg-exec-path gpg-command-decrypt) - (gpg-build-arg-list (cdr gpg-command-decrypt) nil) - ciphertext plaintext result - (if passphrase passphrase (gpg-passphrase-read))) - (when passphrase - (gpg-passphrase-clear-string passphrase))) - -;;;###autoload -(defun gpg-sign-cleartext - (plaintext signed-text result &optional passphrase sign-with-key) - "Sign buffer PLAINTEXT, and store PLAINTEXT with signature in -SIGNED-TEXT. -Reads a missing PASSPHRASE using `gpg-passphrase-read'. Uses key ID -SIGN-WITH-KEY if given, otherwise the default key ID. Returns t if -everything worked out well, nil otherwise. Consult buffer RESULT for -details. - -NOTE: Use of this function is deprecated." - (interactive "bBuffer containing plaintext: \nbBuffer for text with signature: \nbBuffer for status information: ") - (let ((subst (list (cons 'sign-with-key - (gpg-build-flag-sign-with-key sign-with-key)) - (cons 'armor gpg-command-flag-armor) - (cons 'textmode gpg-command-flag-textmode)))) - (gpg-call-process (gpg-exec-path gpg-command-sign-cleartext) - (gpg-build-arg-list (cdr gpg-command-sign-cleartext) - subst) - plaintext signed-text result - (if passphrase passphrase (gpg-passphrase-read)))) - (when passphrase - (gpg-passphrase-clear-string passphrase))) - -;;;###autoload -(defun gpg-sign-detached - (plaintext signature result &optional passphrase sign-with-key - armor textmode) - "Sign buffer PLAINTEXT, and store SIGNATURE in that buffer. -Reads a missing PASSPHRASE using `gpg-passphrase-read'. Uses key ID -SIGN-WITH-KEY if given, otherwise the default key ID. Returns t if -everything worked out well, nil otherwise. Consult buffer RESULT for -details. ARMOR the result and activate canonical TEXTMODE if -requested." - (interactive "bBuffer containing plaintext: \nbBuffer for text with signature: \nbBuffer for status information: ") - (let ((subst (list (cons 'sign-with-key - (gpg-build-flag-sign-with-key sign-with-key)) - (cons 'armor (if armor gpg-command-flag-armor)) - (cons 'textmode (if armor gpg-command-flag-textmode))))) - (gpg-call-process (gpg-exec-path gpg-command-sign-detached) - (gpg-build-arg-list (cdr gpg-command-sign-detached) - subst) - plaintext signature result - (if passphrase passphrase (gpg-passphrase-read)))) - (when passphrase - (gpg-passphrase-clear-string passphrase))) - - -;;;###autoload -(defun gpg-sign-encrypt - (plaintext ciphertext result recipients &optional passphrase sign-with-key - armor textmode) - "Sign buffer PLAINTEXT, and store SIGNATURE in that buffer. -RECIPIENTS is a list of key IDs used for encryption. This function -reads a missing PASSPHRASE using `gpg-passphrase-read', and uses key -ID SIGN-WITH-KEY for the signature if given, otherwise the default key -ID. Returns t if everything worked out well, nil otherwise. Consult -buffer RESULT for details. ARMOR the result and activate canonical -TEXTMODE if requested." - (interactive (list - (read-buffer "Buffer containing plaintext: " nil t) - (read-buffer "Buffer for ciphertext: " nil t) - (read-buffer "Buffer for status informationt: " nil t) - (gpg-read-recipients))) - (let ((subst `((sign-with-key . ,(gpg-build-flag-sign-with-key - sign-with-key)) - (plaintext-file . stdin-file) - (recipients . ,(gpg-build-flag-recipients recipients)) - (armor ,(if armor gpg-command-flag-armor)) - (textmode ,(if armor gpg-command-flag-textmode))))) - (gpg-call-process (gpg-exec-path gpg-command-sign-encrypt) - (gpg-build-arg-list (cdr gpg-command-sign-encrypt) - subst) - plaintext ciphertext result - (if passphrase passphrase (gpg-passphrase-read)))) - (when passphrase - (gpg-passphrase-clear-string passphrase))) - - -;;;###autoload -(defun gpg-encrypt - (plaintext ciphertext result recipients &optional passphrase armor textmode) - "Encrypt buffer PLAINTEXT, and store CIPHERTEXT in that buffer. -RECIPIENTS is a list of key IDs used for encryption. Returns t if -everything worked out well, nil otherwise. Consult buffer RESULT for -details. ARMOR the result and activate canonical -TEXTMODE if requested." - (interactive (list - (read-buffer "Buffer containing plaintext: " nil t) - (read-buffer "Buffer for ciphertext: " nil t) - (read-buffer "Buffer for status informationt: " nil t) - (gpg-read-recipients))) - (let ((subst `((plaintext-file . stdin-file) - (recipients . ,(gpg-build-flag-recipients recipients)) - (armor ,(if armor gpg-command-flag-armor)) - (textmode ,(if armor gpg-command-flag-textmode))))) - (gpg-call-process (gpg-exec-path gpg-command-encrypt) - (gpg-build-arg-list (cdr gpg-command-encrypt) subst) - plaintext ciphertext result nil)) - (when passphrase - (gpg-passphrase-clear-string passphrase))) - - -;;;; Key management - -;;; ADT: OpenPGP Key - -(defun gpg-key-make (user-id key-id unique-id length algorithm - creation-date expire-date validity trust) - "Create a new key object (for internal use only)." - (vector - ;; 0 1 2 3 4 - user-id key-id unique-id length algorithm - ;; 5 6 7 8 - creation-date expire-date validity trust)) - - -(defun gpg-key-p (key) - "Return t if KEY is a key specification." - (and (arrayp key) (equal (length key) 9) key)) - -(defmacro gpg-key-primary-user-id (key) - "The primary user ID for KEY (human-readable). -DO NOT USE this ID for selecting recipients. It is probably not -unique." - (list 'car (list 'aref key 0))) - -(defmacro gpg-key-user-ids (key) - "A list of additional user IDs for KEY (human-readable). -DO NOT USE these IDs for selecting recipients. They are probably not -unique." - (list 'cdr (list 'aref key 0))) - -(defmacro gpg-key-id (key) - "The key ID of KEY. -DO NOT USE this ID for selecting recipients. It is not guaranteed to -be unique." - (list 'aref key 1)) - -(defun gpg-short-key-id (key) - "The short key ID of KEY." - (let* ((id (gpg-key-id key)) - (len (length id))) - (if (> len 8) - (substring id (- len 8)) - id))) - -(defmacro gpg-key-unique-id (key) - "A non-standard ID of KEY which is only valid locally. -This ID can be used to specify recipients in a safe manner. Note, -even this ID might not be unique unless GnuPG is used." - (list 'aref key 2)) - -(defmacro gpg-key-unique-id-list (key-list) - "Like `gpg-key-unique-id', but operate on a list." - `(mapcar (lambda (key) (gpg-key-unique-id key)) - ,key-list)) - -(defmacro gpg-key-length (key) - "Returns the key length." - (list 'aref key 3)) - -(defmacro gpg-key-algorithm (key) - "The encryption algorithm used by KEY. -One of the symbols `rsa', `rsa-encrypt', `rsa-sign', `elgamal', -`elgamal-encrypt', `dsa'." - (list 'aref key 4)) - -(defmacro gpg-key-creation-date (key) - "A string with the creation date of KEY in ISO format." - (list 'aref key 5)) - -(defmacro gpg-key-expire-date (key) - "A string with the expiration date of KEY in ISO format." - (list 'aref key 6)) - -(defmacro gpg-key-validity (key) - "The calculated validity of KEY. -One of the symbols `not-known', `disabled', `revoked', `expired', -`undefined', `trust-none', `trust-marginal', `trust-full', -`trust-ultimate' (see the GnuPG documentation for details)." - (list 'aref key 7)) - -(defmacro gpg-key-trust (key) - "The assigned trust for KEY. -One of the symbols `not-known', `undefined', `trust-none', -`trust-marginal', `trust-full' (see the GnuPG -documentation for details)." - (list 'aref key 8)) - -(defun gpg-key-lessp (a b) - "Returns t if primary user ID of A is less than B." - (let ((res (compare-strings (gpg-key-primary-user-id a) 0 nil - (gpg-key-primary-user-id b) 0 nil - t))) - (if (eq res t) - nil - (< res 0)))) - -;;; Accessing the key database: - -;; Internal functions: - -(defmacro gpg-key-list-keys-skip-field () - '(search-forward ":" eol 'move)) - -(defmacro gpg-key-list-keys-get-field () - '(buffer-substring (point) (if (gpg-key-list-keys-skip-field) - (1- (point)) - eol))) -(defmacro gpg-key-list-keys-string-field () - '(gpg-key-list-keys-get-field)) - -(defmacro gpg-key-list-keys-read-field () - (let ((field (make-symbol "field"))) - `(let ((,field (gpg-key-list-keys-get-field))) - (if (equal (length ,field) 0) - nil - (read ,field))))) - -(defun gpg-key-list-keys-parse-line () - "Parse the line in the current buffer and return a vector of fields." - (let* ((eol (line-end-position)) - (v (if (eolp) - nil - (vector - (gpg-key-list-keys-read-field) ; type - (gpg-key-list-keys-get-field) ; trust - (gpg-key-list-keys-read-field) ; key length - (gpg-key-list-keys-read-field) ; algorithm - (gpg-key-list-keys-get-field) ; key ID - (gpg-key-list-keys-get-field) ; creation data - (gpg-key-list-keys-get-field) ; expire - (gpg-key-list-keys-get-field) ; unique (local) ID - (gpg-key-list-keys-get-field) ; ownertrust - (gpg-key-list-keys-string-field) ; user ID - )))) - (if (eolp) - (when v - (forward-char 1)) - (error "Too many fields in GnuPG key database")) - v)) - -(defconst gpg-pubkey-algo-alist - '((1 . rsa) - (2 . rsa-encrypt-only) - (3 . rsa-sign-only) - (16 . elgamal-encrypt-only) - (17 . dsa) - (20 . elgamal)) - "Alist mapping OpenPGP public key algorithm numbers to symbols.") - -(defconst gpg-trust-alist - '((?- . not-known) - (?o . not-known) - (?d . disabled) - (?r . revoked) - (?e . expired) - (?q . trust-undefined) - (?n . trust-none) - (?m . trust-marginal) - (?f . trust-full) - (?u . trust-ultimate)) - "Alist mapping GnuPG trust value short forms to long symbols.") - -(defmacro gpg-key-list-keys-in-buffer-store () - '(when primary-user-id - (sort user-id 'string-lessp) - (push (gpg-key-make (cons primary-user-id user-id) - key-id unique-id key-length - algorithm creation-date - expire-date validity trust) - key-list))) - -(defun gpg-key-list-keys-in-buffer (&optional buffer) - "Return a list of keys for BUFFER. -If BUFFER is omitted, use current buffer." - (with-current-buffer (if buffer buffer (current-buffer)) - (goto-char (point-min)) - ;; Skip key ring filename written by GnuPG. - (search-forward "\n---------------------------\n" nil t) - ;; Loop over all lines in buffer and analyze them. - (let (primary-user-id user-id key-id unique-id ; current key components - key-length algorithm creation-date expire-date validity trust - line ; fields in current line - key-list) ; keys gather so far - - (while (setq line (gpg-key-list-keys-parse-line)) - (cond - ;; Public or secret key. - ((memq (aref line 0) '(pub sec)) - ;; Store previous key, if any. - (gpg-key-list-keys-in-buffer-store) - ;; Record field values. - (setq primary-user-id (aref line 9)) - (setq user-id nil) - (setq key-id (aref line 4)) - ;; We use the key ID if no unique ID is available. - (setq unique-id (if (> (length (aref line 7)) 0) - (concat "#" (aref line 7)) - (concat "0x" key-id))) - (setq key-length (aref line 2)) - (setq algorithm (assq (aref line 3) gpg-pubkey-algo-alist)) - (if algorithm - (setq algorithm (cdr algorithm)) - (error "Unknown algorithm %s" (aref line 3))) - (setq creation-date (if (> (length (aref line 5)) 0) - (aref line 5))) - (setq expire-date (if (> (length (aref line 6)) 0) - (aref line 6))) - (setq validity (assq (aref (aref line 1) 0) gpg-trust-alist)) - (if validity - (setq validity (cdr validity)) - (error "Unknown validity specification %S" (aref line 1))) - (setq trust (assq (aref (aref line 8) 0) gpg-trust-alist)) - (if trust - (setq trust (cdr trust)) - (error "Unknown trust specification %S" (aref line 8)))) - - ;; Additional user ID - ((eq 'uid (aref line 0)) - (setq user-id (cons (aref line 9) user-id))) - - ;; Subkeys are ignored for now. - ((memq (aref line 0) '(sub ssb)) - t) - (t (error "Unknown record type %S" (aref line 0))))) - - ;; Store the key retrieved last. - (gpg-key-list-keys-in-buffer-store) - ;; Sort the keys according to the primary user ID. - (sort key-list 'gpg-key-lessp)))) - -(defun gpg-key-list-keyspec (command &optional keyspec stderr ignore-error) - "Insert the output of COMMAND before point in current buffer." - (let* ((cmd (gpg-exec-path command)) - (key (if (equal keyspec "") nil keyspec)) - (args (gpg-build-arg-list (cdr command) `((key-id . ,key)))) - exit-status) - (setq exit-status - (apply 'call-process-region - (point-min) (point-min) ; no data - cmd - nil ; don't delete - (if stderr t '(t nil)) - nil ; don't display - args)) - (unless (or ignore-error (equal exit-status 0)) - (error "GnuPG command exited unsuccessfully")))) - - -(defun gpg-key-list-keyspec-parse (command &optional keyspec) - "Return a list of keys matching KEYSPEC. -COMMAND is used to obtain the key list. The usual substring search -for keys is performed." - (with-temp-buffer - (buffer-disable-undo) - (gpg-key-list-keyspec command keyspec) - (gpg-key-list-keys-in-buffer))) - -;;;###autoload -(defun gpg-key-list-keys (&optional keyspec) - "A list of public keys matching KEYSPEC. -The usual substring search for keys is performed." - (gpg-key-list-keyspec-parse gpg-command-key-public-ring keyspec)) - -;;;###autoload -(defun gpg-key-list-secret-keys (&optional keyspec) - "A list of secret keys matching KEYSPEC. -The usual substring search for keys is performed." - (gpg-key-list-keyspec-parse gpg-command-key-secret-ring keyspec)) - -;;;###autoload -(defun gpg-key-insert-public-key (key) - "Inserts the public key(s) matching KEYSPEC. -The ASCII-armored key is inserted before point into current buffer." - (gpg-key-list-keyspec gpg-command-key-export key)) - -;;;###autoload -(defun gpg-key-insert-information (key) - "Insert human-readable information (including fingerprint) on KEY. -Insertion takes place in current buffer before point." - (gpg-key-list-keyspec gpg-command-key-verify key)) - -;;;###autoload -(defun gpg-key-retrieve (key) - "Fetch KEY from default key server. -KEY is a key ID or a list of key IDs. Status information about this -operation is inserted into the current buffer before point." - (gpg-key-list-keyspec gpg-command-key-retrieve key t t)) - -;;;###autoload -(defun gpg-key-add-to-ring (key result) - "Adds key in buffer KEY to the GnuPG key ring. -Human-readable information on the RESULT is stored in buffer RESULT -before point.") - -(provide 'gpg) - -;;; gpg.el ends here diff --git a/lisp/md5.el b/lisp/md5.el deleted file mode 100644 index a246b1a..0000000 --- a/lisp/md5.el +++ /dev/null @@ -1,413 +0,0 @@ -;;; md5.el -- MD5 Message Digest Algorithm -;;; Gareth Rees - -;; LCD Archive Entry: -;; md5|Gareth Rees|gdr11@cl.cam.ac.uk| -;; MD5 cryptographic message digest algorithm| -;; 13-Nov-95|1.0|~/misc/md5.el.Z| - -;;; Details: ------------------------------------------------------------------ - -;; This is a direct translation into Emacs LISP of the reference C -;; implementation of the MD5 Message-Digest Algorithm written by RSA -;; Data Security, Inc. -;; -;; The algorithm takes a message (that is, a string of bytes) and -;; computes a 16-byte checksum or "digest" for the message. This digest -;; is supposed to be cryptographically strong in the sense that if you -;; are given a 16-byte digest D, then there is no easier way to -;; construct a message whose digest is D than to exhaustively search the -;; space of messages. However, the robustness of the algorithm has not -;; been proven, and a similar algorithm (MD4) was shown to be unsound, -;; so treat with caution! -;; -;; The C algorithm uses 32-bit integers; because GNU Emacs -;; implementations provide 28-bit integers (with 24-bit integers on -;; versions prior to 19.29), the code represents a 32-bit integer as the -;; cons of two 16-bit integers. The most significant word is stored in -;; the car and the least significant in the cdr. The algorithm requires -;; at least 17 bits of integer representation in order to represent the -;; carry from a 16-bit addition. - -;;; Usage: -------------------------------------------------------------------- - -;; To compute the MD5 Message Digest for a message M (represented as a -;; string or as a vector of bytes), call -;; -;; (md5-encode M) -;; -;; which returns the message digest as a vector of 16 bytes. If you -;; need to supply the message in pieces M1, M2, ... Mn, then call -;; -;; (md5-init) -;; (md5-update M1) -;; (md5-update M2) -;; ... -;; (md5-update Mn) -;; (md5-final) - -;;; Copyright and licence: ---------------------------------------------------- - -;; Copyright (C) 1995 by Gareth Rees -;; Derived from the RSA Data Security, Inc. MD5 Message-Digest Algorithm -;; -;; md5.el 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. -;; -;; md5.el 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. -;; -;; The original copyright notice is given below, as required by the -;; licence for the original code. This code is distributed under *both* -;; RSA's original licence and the GNU General Public Licence. (There -;; should be no problems, as the former is more liberal than the -;; latter). - -;;; Original copyright notice: ------------------------------------------------ - -;; Copyright (C) 1990, RSA Data Security, Inc. All rights reserved. -;; -;; License to copy and use this software is granted provided that it is -;; identified as the "RSA Data Security, Inc. MD5 Message- Digest -;; Algorithm" in all material mentioning or referencing this software or -;; this function. -;; -;; License is also granted to make and use derivative works provided -;; that such works are identified as "derived from the RSA Data -;; Security, Inc. MD5 Message-Digest Algorithm" in all material -;; mentioning or referencing the derived work. -;; -;; RSA Data Security, Inc. makes no representations concerning either -;; the merchantability of this software or the suitability of this -;; software for any particular purpose. It is provided "as is" without -;; express or implied warranty of any kind. -;; -;; These notices must be retained in any copies of any part of this -;; documentation and/or software. - -;;; Code: --------------------------------------------------------------------- - -(defvar md5-program "md5sum" - "*Program that reads a message on its standard input and writes an -MD5 digest on its output.") - -(defvar md5-maximum-internal-length 4096 - "*The maximum size of a piece of data that should use the MD5 routines -written in lisp. If a message exceeds this, it will be run through an -external filter for processing. Also see the `md5-program' variable. -This variable has no effect if you call the md5-init|update|final -functions - only used by the `md5' function's simpler interface.") - -(defvar md5-bits (make-vector 4 0) - "Number of bits handled, modulo 2^64. -Represented as four 16-bit numbers, least significant first.") -(defvar md5-buffer (make-vector 4 '(0 . 0)) - "Scratch buffer (four 32-bit integers).") -(defvar md5-input (make-vector 64 0) - "Input buffer (64 bytes).") - -(defun md5-unhex (x) - (if (> x ?9) - (if (>= x ?a) - (+ 10 (- x ?a)) - (+ 10 (- x ?A))) - (- x ?0))) - -(defun md5-encode (message) - "Encodes MESSAGE using the MD5 message digest algorithm. -MESSAGE must be a string or an array of bytes. -Returns a vector of 16 bytes containing the message digest." - (if (<= (length message) md5-maximum-internal-length) - (progn - (md5-init) - (md5-update message) - (md5-final)) - (save-excursion - (set-buffer (get-buffer-create " *md5-work*")) - (erase-buffer) - (insert message) - (call-process-region (point-min) (point-max) - (or shell-file-name "/bin/sh") - t (current-buffer) nil - "-c" md5-program) - ;; MD5 digest is 32 chars long - ;; mddriver adds a newline to make neaten output for tty - ;; viewing, make sure we leave it behind. - (let ((data (buffer-substring (point-min) (+ (point-min) 32))) - (vec (make-vector 16 0)) - (ctr 0)) - (while (< ctr 16) - (aset vec ctr (+ (* 16 (md5-unhex (aref data (* ctr 2)))) - (md5-unhex (aref data (1+ (* ctr 2)))))) - (setq ctr (1+ ctr))))))) - -(defsubst md5-add (x y) - "Return 32-bit sum of 32-bit integers X and Y." - (let ((m (+ (car x) (car y))) - (l (+ (cdr x) (cdr y)))) - (cons (logand 65535 (+ m (lsh l -16))) (logand l 65535)))) - -;; FF, GG, HH and II are basic MD5 functions, providing transformations -;; for rounds 1, 2, 3 and 4 respectively. Each function follows this -;; pattern of computation (where ROTATE(x,y) means rotate 32-bit value x -;; by y bits to the left): -;; -;; FF(a,b,c,d,x,s,ac) = ROTATE(a + F(b,c,d) + x + ac,s) + b -;; -;; so we use the macro `md5-make-step' to construct each one. The -;; helper functions F, G, H and I operate on 16-bit numbers; the full -;; operation splits its inputs, operates on the halves separately and -;; then puts the results together. - -(defsubst md5-F (x y z) (logior (logand x y) (logand (lognot x) z))) -(defsubst md5-G (x y z) (logior (logand x z) (logand y (lognot z)))) -(defsubst md5-H (x y z) (logxor x y z)) -(defsubst md5-I (x y z) (logxor y (logior x (logand 65535 (lognot z))))) - -(defmacro md5-make-step (name func) - (` - (defun (, name) (a b c d x s ac) - (let* - ((m1 (+ (car a) ((, func) (car b) (car c) (car d)) (car x) (car ac))) - (l1 (+ (cdr a) ((, func) (cdr b) (cdr c) (cdr d)) (cdr x) (cdr ac))) - (m2 (logand 65535 (+ m1 (lsh l1 -16)))) - (l2 (logand 65535 l1)) - (m3 (logand 65535 (if (> s 15) - (+ (lsh m2 (- s 32)) (lsh l2 (- s 16))) - (+ (lsh m2 s) (lsh l2 (- s 16)))))) - (l3 (logand 65535 (if (> s 15) - (+ (lsh l2 (- s 32)) (lsh m2 (- s 16))) - (+ (lsh l2 s) (lsh m2 (- s 16))))))) - (md5-add (cons m3 l3) b))))) - -(md5-make-step md5-FF md5-F) -(md5-make-step md5-GG md5-G) -(md5-make-step md5-HH md5-H) -(md5-make-step md5-II md5-I) - -(defun md5-init () - "Initialise the state of the message-digest routines." - (aset md5-bits 0 0) - (aset md5-bits 1 0) - (aset md5-bits 2 0) - (aset md5-bits 3 0) - (aset md5-buffer 0 '(26437 . 8961)) - (aset md5-buffer 1 '(61389 . 43913)) - (aset md5-buffer 2 '(39098 . 56574)) - (aset md5-buffer 3 '( 4146 . 21622))) - -(defun md5-update (string) - "Update the current MD5 state with STRING (an array of bytes)." - (let ((len (length string)) - (i 0) - (j 0)) - (while (< i len) - ;; Compute number of bytes modulo 64 - (setq j (% (/ (aref md5-bits 0) 8) 64)) - - ;; Store this byte (truncating to 8 bits to be sure) - (aset md5-input j (logand 255 (aref string i))) - - ;; Update number of bits by 8 (modulo 2^64) - (let ((c 8) (k 0)) - (while (and (> c 0) (< k 4)) - (let ((b (aref md5-bits k))) - (aset md5-bits k (logand 65535 (+ b c))) - (setq c (if (> b (- 65535 c)) 1 0) - k (1+ k))))) - - ;; Increment number of bytes processed - (setq i (1+ i)) - - ;; When 64 bytes accumulated, pack them into sixteen 32-bit - ;; integers in the array `in' and then tranform them. - (if (= j 63) - (let ((in (make-vector 16 (cons 0 0))) - (k 0) - (kk 0)) - (while (< k 16) - (aset in k (md5-pack md5-input kk)) - (setq k (+ k 1) kk (+ kk 4))) - (md5-transform in)))))) - -(defun md5-pack (array i) - "Pack the four bytes at ARRAY reference I to I+3 into a 32-bit integer." - (cons (+ (lsh (aref array (+ i 3)) 8) (aref array (+ i 2))) - (+ (lsh (aref array (+ i 1)) 8) (aref array (+ i 0))))) - -(defun md5-byte (array n b) - "Unpack byte B (0 to 3) from Nth member of ARRAY of 32-bit integers." - (let ((e (aref array n))) - (cond ((eq b 0) (logand 255 (cdr e))) - ((eq b 1) (lsh (cdr e) -8)) - ((eq b 2) (logand 255 (car e))) - ((eq b 3) (lsh (car e) -8))))) - -(defun md5-final () - (let ((in (make-vector 16 (cons 0 0))) - (j 0) - (digest (make-vector 16 0)) - (padding)) - - ;; Save the number of bits in the message - (aset in 14 (cons (aref md5-bits 1) (aref md5-bits 0))) - (aset in 15 (cons (aref md5-bits 3) (aref md5-bits 2))) - - ;; Compute number of bytes modulo 64 - (setq j (% (/ (aref md5-bits 0) 8) 64)) - - ;; Pad out computation to 56 bytes modulo 64 - (setq padding (make-vector (if (< j 56) (- 56 j) (- 120 j)) 0)) - (aset padding 0 128) - (md5-update padding) - - ;; Append length in bits and transform - (let ((k 0) (kk 0)) - (while (< k 14) - (aset in k (md5-pack md5-input kk)) - (setq k (+ k 1) kk (+ kk 4)))) - (md5-transform in) - - ;; Store the results in the digest - (let ((k 0) (kk 0)) - (while (< k 4) - (aset digest (+ kk 0) (md5-byte md5-buffer k 0)) - (aset digest (+ kk 1) (md5-byte md5-buffer k 1)) - (aset digest (+ kk 2) (md5-byte md5-buffer k 2)) - (aset digest (+ kk 3) (md5-byte md5-buffer k 3)) - (setq k (+ k 1) kk (+ kk 4)))) - - ;; Return digest - digest)) - -;; It says in the RSA source, "Note that if the Mysterious Constants are -;; arranged backwards in little-endian order and decrypted with the DES -;; they produce OCCULT MESSAGES!" Security through obscurity? - -(defun md5-transform (in) - "Basic MD5 step. Transform md5-buffer based on array IN." - (let ((a (aref md5-buffer 0)) - (b (aref md5-buffer 1)) - (c (aref md5-buffer 2)) - (d (aref md5-buffer 3))) - (setq - a (md5-FF a b c d (aref in 0) 7 '(55146 . 42104)) - d (md5-FF d a b c (aref in 1) 12 '(59591 . 46934)) - c (md5-FF c d a b (aref in 2) 17 '( 9248 . 28891)) - b (md5-FF b c d a (aref in 3) 22 '(49597 . 52974)) - a (md5-FF a b c d (aref in 4) 7 '(62844 . 4015)) - d (md5-FF d a b c (aref in 5) 12 '(18311 . 50730)) - c (md5-FF c d a b (aref in 6) 17 '(43056 . 17939)) - b (md5-FF b c d a (aref in 7) 22 '(64838 . 38145)) - a (md5-FF a b c d (aref in 8) 7 '(27008 . 39128)) - d (md5-FF d a b c (aref in 9) 12 '(35652 . 63407)) - c (md5-FF c d a b (aref in 10) 17 '(65535 . 23473)) - b (md5-FF b c d a (aref in 11) 22 '(35164 . 55230)) - a (md5-FF a b c d (aref in 12) 7 '(27536 . 4386)) - d (md5-FF d a b c (aref in 13) 12 '(64920 . 29075)) - c (md5-FF c d a b (aref in 14) 17 '(42617 . 17294)) - b (md5-FF b c d a (aref in 15) 22 '(18868 . 2081)) - a (md5-GG a b c d (aref in 1) 5 '(63006 . 9570)) - d (md5-GG d a b c (aref in 6) 9 '(49216 . 45888)) - c (md5-GG c d a b (aref in 11) 14 '( 9822 . 23121)) - b (md5-GG b c d a (aref in 0) 20 '(59830 . 51114)) - a (md5-GG a b c d (aref in 5) 5 '(54831 . 4189)) - d (md5-GG d a b c (aref in 10) 9 '( 580 . 5203)) - c (md5-GG c d a b (aref in 15) 14 '(55457 . 59009)) - b (md5-GG b c d a (aref in 4) 20 '(59347 . 64456)) - a (md5-GG a b c d (aref in 9) 5 '( 8673 . 52710)) - d (md5-GG d a b c (aref in 14) 9 '(49975 . 2006)) - c (md5-GG c d a b (aref in 3) 14 '(62677 . 3463)) - b (md5-GG b c d a (aref in 8) 20 '(17754 . 5357)) - a (md5-GG a b c d (aref in 13) 5 '(43491 . 59653)) - d (md5-GG d a b c (aref in 2) 9 '(64751 . 41976)) - c (md5-GG c d a b (aref in 7) 14 '(26479 . 729)) - b (md5-GG b c d a (aref in 12) 20 '(36138 . 19594)) - a (md5-HH a b c d (aref in 5) 4 '(65530 . 14658)) - d (md5-HH d a b c (aref in 8) 11 '(34673 . 63105)) - c (md5-HH c d a b (aref in 11) 16 '(28061 . 24866)) - b (md5-HH b c d a (aref in 14) 23 '(64997 . 14348)) - a (md5-HH a b c d (aref in 1) 4 '(42174 . 59972)) - d (md5-HH d a b c (aref in 4) 11 '(19422 . 53161)) - c (md5-HH c d a b (aref in 7) 16 '(63163 . 19296)) - b (md5-HH b c d a (aref in 10) 23 '(48831 . 48240)) - a (md5-HH a b c d (aref in 13) 4 '(10395 . 32454)) - d (md5-HH d a b c (aref in 0) 11 '(60065 . 10234)) - c (md5-HH c d a b (aref in 3) 16 '(54511 . 12421)) - b (md5-HH b c d a (aref in 6) 23 '( 1160 . 7429)) - a (md5-HH a b c d (aref in 9) 4 '(55764 . 53305)) - d (md5-HH d a b c (aref in 12) 11 '(59099 . 39397)) - c (md5-HH c d a b (aref in 15) 16 '( 8098 . 31992)) - b (md5-HH b c d a (aref in 2) 23 '(50348 . 22117)) - a (md5-II a b c d (aref in 0) 6 '(62505 . 8772)) - d (md5-II d a b c (aref in 7) 10 '(17194 . 65431)) - c (md5-II c d a b (aref in 14) 15 '(43924 . 9127)) - b (md5-II b c d a (aref in 5) 21 '(64659 . 41017)) - a (md5-II a b c d (aref in 12) 6 '(25947 . 22979)) - d (md5-II d a b c (aref in 3) 10 '(36620 . 52370)) - c (md5-II c d a b (aref in 10) 15 '(65519 . 62589)) - b (md5-II b c d a (aref in 1) 21 '(34180 . 24017)) - a (md5-II a b c d (aref in 8) 6 '(28584 . 32335)) - d (md5-II d a b c (aref in 15) 10 '(65068 . 59104)) - c (md5-II c d a b (aref in 6) 15 '(41729 . 17172)) - b (md5-II b c d a (aref in 13) 21 '(19976 . 4513)) - a (md5-II a b c d (aref in 4) 6 '(63315 . 32386)) - d (md5-II d a b c (aref in 11) 10 '(48442 . 62005)) - c (md5-II c d a b (aref in 2) 15 '(10967 . 53947)) - b (md5-II b c d a (aref in 9) 21 '(60294 . 54161))) - - (aset md5-buffer 0 (md5-add (aref md5-buffer 0) a)) - (aset md5-buffer 1 (md5-add (aref md5-buffer 1) b)) - (aset md5-buffer 2 (md5-add (aref md5-buffer 2) c)) - (aset md5-buffer 3 (md5-add (aref md5-buffer 3) d)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Here begins the merger with the XEmacs API and the md5.el from the URL -;;; package. Courtesy wmperry@spry.com -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun md5 (object &optional start end coding noerror) - "Return the MD5 (a secure message digest algorithm) of an object. -OBJECT is either a string or a buffer. -Optional arguments START and END denote buffer positions for computing the -hash of a portion of OBJECT. - -The optional CODING and NOERROR arguments are ignored. They are only -placeholders to ensure the compatibility with XEmacsen with file-coding or -Mule support." - (let ((buffer nil)) - (unwind-protect - (save-excursion - (setq buffer (generate-new-buffer " *md5-work*")) - (set-buffer buffer) - (cond - ((bufferp object) - (insert-buffer-substring object start end)) - ((stringp object) - (insert (if (or start end) - (substring object start end) - object))) - (t nil)) - (prog1 - (if (<= (point-max) md5-maximum-internal-length) - (mapconcat - (function (lambda (node) (format "%02x" node))) - (md5-encode (buffer-string)) - "") - (call-process-region (point-min) (point-max) - (or shell-file-name "/bin/sh") - t buffer nil - "-c" md5-program) - ;; MD5 digest is 32 chars long - ;; mddriver adds a newline to make neaten output for tty - ;; viewing, make sure we leave it behind. - (buffer-substring (point-min) (+ (point-min) 32))) - (kill-buffer buffer))) - (and buffer (kill-buffer buffer) nil)))) - -(provide 'md5) - -;;; md5.el ends here ---------------------------------------------------------- diff --git a/lisp/message.el b/lisp/message.el index 0b9165c..6229384 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -1145,7 +1145,7 @@ See also the documentations for the following variables: (setq message-font-lock-last-position nil))) (defvar message-font-lock-keywords-1 - (let ((content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)")) + (let ((content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)\n?")) `((,(concat "^\\([Tt]o:\\)" content) (1 'message-header-name-face) (2 'message-header-to-face nil t)) @@ -2126,7 +2126,7 @@ With the prefix argument FORCE, insert the header anyway." (unless (bolp) (save-excursion (beginning-of-line) - (when (looking-at (concat prefix + (when (looking-at (concat prefix "\\|" supercite-thing)) (setq quoted (match-string 0)))) (insert "\n")) diff --git a/lisp/mm-decode.el b/lisp/mm-decode.el index dba6b1f..bbd2e8b 100644 --- a/lisp/mm-decode.el +++ b/lisp/mm-decode.el @@ -144,6 +144,8 @@ (and (or (featurep 'nas-sound) (featurep 'native-sound)) (device-sound-enabled-p)))) ("application/pgp-signature" ignore identity) + ("application/x-pkcs7-signature" ignore identity) + ("application/pkcs7-signature" ignore identity) ("multipart/alternative" ignore identity) ("multipart/mixed" ignore identity) ("multipart/related" ignore identity)) @@ -156,7 +158,8 @@ (defcustom mm-inlined-types '("image/.*" "text/.*" "message/delivery-status" "message/rfc822" "message/partial" "message/external-body" "application/emacs-lisp" - "application/pgp-signature") + "application/pgp-signature" "application/x-pkcs7-signature" + "application/pkcs7-signature") "List of media types that are to be displayed inline." :type '(repeat string) :group 'mime-display) @@ -164,8 +167,9 @@ (defcustom mm-automatic-display '("text/plain" "text/enriched" "text/richtext" "text/html" "text/x-vcard" "image/.*" "message/delivery-status" "multipart/.*" - "message/rfc822" "text/x-patch" "application/pgp-signature" - "application/emacs-lisp") + "message/rfc822" "text/x-patch" "application/pgp-signature" + "application/emacs-lisp" "application/x-pkcs7-signature" + "application/pkcs7-signature") "A list of MIME types to be displayed automatically." :type '(repeat string) :group 'mime-display) @@ -221,9 +225,12 @@ to: (defvar mm-dissect-default-type "text/plain") (autoload 'mml2015-verify "mml2015") +(autoload 'mml-smime-verify "mml-smime") (defvar mm-verify-function-alist - '(("application/pgp-signature" . mml2015-verify))) + '(("application/pgp-signature" mml2015-verify "PGP") + ("application/pkcs7-signature" mml-smime-verify "S/MIME") + ("application/x-pkcs7-signature" mml-smime-verify "S/MIME"))) (defcustom mm-verify-option nil "Option of verifying signed parts. @@ -238,7 +245,7 @@ to: (autoload 'mml2015-decrypt "mml2015") (defvar mm-decrypt-function-alist - '(("application/pgp-encrypted" . mml2015-decrypt))) + '(("application/pgp-encrypted" mml2015-decrypt "PGP"))) (defcustom mm-decrypt-option nil "Option of decrypting signed parts. @@ -250,6 +257,16 @@ to: (item :tag "ask" nil)) :group 'gnus-article) +(defcustom mm-snarf-option nil + "Option of snarfing PGP key. +`never', not snarf; `always', always snarf; +`known', only snarf known protocols. Otherwise, ask user." + :type '(choice (item always) + (item never) + (item :tag "only known protocols" known) + (item :tag "ask" nil)) + :group 'gnus-article) + (defvar mm-viewer-completion-map (let ((map (make-sparse-keymap 'mm-viewer-completion-map))) (set-keymap-parent map minibuffer-local-completion-map) @@ -876,6 +893,8 @@ external if displayed external." (mm-image-fit-p handle))) (defun mm-find-part-by-type (handles type &optional notp) + "Search in HANDLES for part with TYPE. +If NOTP, returns first non-matching part." (let (handle) (while handles (if (if notp @@ -933,37 +952,41 @@ external if displayed external." (cond ((equal subtype "signed") (setq protocol (mail-content-type-get ctl 'protocol)) - (setq func (cdr (assoc protocol mm-verify-function-alist))) + (setq func (nth 1 (assoc protocol mm-verify-function-alist))) (if (cond ((eq mm-verify-option 'never) nil) ((eq mm-verify-option 'always) t) ((eq mm-verify-option 'known) func) - (t (y-or-n-p - (format "Verify signed part(protocol=%s)?" protocol)))) + (t (y-or-n-p + (format "Verify signed (%s) part? " + (or (nth 2 (assoc protocol mm-verify-function-alist)) + (format "protocol=%s" protocol)))))) (condition-case err (save-excursion (if func (funcall func parts ctl) - (error (format "Unknown sign protocol(%s)" protocol)))) + (error (format "Unknown sign protocol (%s)" protocol)))) (error - (unless (y-or-n-p (format "%s, continue?" err)) + (unless (y-or-n-p (format "%s, continue? " err)) (error "Verify failure.")))))) ((equal subtype "encrypted") (setq protocol (mail-content-type-get ctl 'protocol)) - (setq func (cdr (assoc protocol mm-decrypt-function-alist))) + (setq func (nth 1 (assoc protocol mm-decrypt-function-alist))) (if (cond ((eq mm-decrypt-option 'never) nil) ((eq mm-decrypt-option 'always) t) ((eq mm-decrypt-option 'known) func) (t (y-or-n-p - (format "Decrypt part (protocol=%s)?" protocol)))) + (format "Decrypt (%s) part? " + (or (nth 2 (assoc protocol mm-decrypt-function-alist)) + (format "protocol=%s" protocol)))))) (condition-case err (save-excursion (if func (setq parts (funcall func parts ctl)) - (error (format "Unknown encrypt protocol(%s)" protocol)))) + (error (format "Unknown encrypt protocol (%s)" protocol)))) (error - (unless (y-or-n-p (format "%s, continue?" err)) + (unless (y-or-n-p (format "%s, continue? " err)) (error "Decrypt failure.")))))) (t nil)) parts)) diff --git a/lisp/mm-extern.el b/lisp/mm-extern.el index 2fb535b..f2b20f9 100644 --- a/lisp/mm-extern.el +++ b/lisp/mm-extern.el @@ -52,7 +52,7 @@ (mm-disable-multibyte-mule4) (if (file-exists-p name) (mm-insert-file-contents name nil nil nil nil t) - (error "The file is gone.")))) + (error (format "File %s is gone." name))))) (defun mm-extern-url (handle) (erase-buffer) diff --git a/lisp/mm-util.el b/lisp/mm-util.el index 096d0f4..4a09259 100644 --- a/lisp/mm-util.el +++ b/lisp/mm-util.el @@ -108,7 +108,20 @@ prompt (mapcar (lambda (e) (list (symbol-name (car e)))) mm-mime-mule-charset-alist) - nil t))))))) + nil t)))) + (subst-char-in-string + . (lambda (from to string) ;; stolen (and renamed) from nnheader.el + "Replace characters in STRING from FROM to TO." + (let ((string (substring string 0)) ;Copy string. + (len (length string)) + (idx 0)) + ;; Replace all occurrences of FROM with TO. + (while (< idx len) + (when (= (aref string idx) from) + (aset string idx to)) + (setq idx (1+ idx))) + string))) + ))) (eval-and-compile (defalias 'mm-char-or-char-int-p @@ -203,20 +216,8 @@ used as the line break code type of the coding system." (t nil))) -(static-if (fboundp 'subst-char-in-string) - (defsubst mm-replace-chars-in-string (string from to) - (subst-char-in-string from to string)) - (defun mm-replace-chars-in-string (string from to) - "Replace characters in STRING from FROM to TO." - (let ((string (substring string 0)) ;Copy string. - (len (length string)) - (idx 0)) - ;; Replace all occurrences of FROM with TO. - (while (< idx len) - (when (= (aref string idx) from) - (aset string idx to)) - (setq idx (1+ idx))) - string))) +(defsubst mm-replace-chars-in-string (string from to) + (mm-subst-char-in-string from to string)) (defsubst mm-enable-multibyte () "Enable multibyte in the current buffer." diff --git a/lisp/mm-uu.el b/lisp/mm-uu.el index a97cced..a210b9c 100644 --- a/lisp/mm-uu.el +++ b/lisp/mm-uu.el @@ -2,7 +2,7 @@ ;; Copyright (c) 1998, 1999, 2000 Free Software Foundation, Inc. ;; Author: Shenghuo Zhu -;; Keywords: postscript uudecode binhex shar forward news +;; Keywords: postscript uudecode binhex shar forward gnatsweb pgp ;; This file is part of GNU Emacs. @@ -31,6 +31,7 @@ (require 'nnheader) (require 'mm-decode) (require 'gnus-mailcap) +(require 'mml2015) (eval-and-compile (autoload 'binhex-decode-region "binhex") @@ -38,22 +39,6 @@ (autoload 'uudecode-decode-region "uudecode") (autoload 'uudecode-decode-region-external "uudecode")) -(defun mm-uu-copy-to-buffer (from to) - "Copy the contents of the current buffer to a fresh buffer." - (save-excursion - (let ((obuf (current-buffer))) - (set-buffer (generate-new-buffer " *mm-uu*")) - (insert-buffer-substring obuf from to) - (current-buffer)))) - -;;; postscript - -(defconst mm-uu-postscript-begin-line "^%!PS-") -(defconst mm-uu-postscript-end-line "^%%EOF$") - -(defconst mm-uu-uu-begin-line "^begin[ \t]+[0-7][0-7][0-7][ \t]+") -(defconst mm-uu-uu-end-line "^end[ \t]*$") - (defcustom mm-uu-decode-function 'uudecode-decode-region "*Function to uudecode. Internal function is done in elisp by default, therefore decoding may @@ -63,10 +48,6 @@ decoder, such as uudecode." (item :tag "external" uudecode-decode-region-external)) :group 'gnus-article-mime) -(defconst mm-uu-binhex-begin-line - "^:...............................................................$") -(defconst mm-uu-binhex-end-line ":$") - (defcustom mm-uu-binhex-decode-function 'binhex-decode-region "*Function to binhex decode. Internal function is done in elisp by default, therefore decoding may @@ -76,148 +57,321 @@ decoder, such as hexbin." (item :tag "external" binhex-decode-region-external)) :group 'gnus-article-mime) -(defconst mm-uu-shar-begin-line "^#! */bin/sh") -(defconst mm-uu-shar-end-line "^exit 0\\|^$") - -;;; Thanks to Edward J. Sabol and -;;; Peter von der Ah\'e -(defconst mm-uu-forward-begin-line "^-+ \\(Start of \\)?Forwarded message") -(defconst mm-uu-forward-end-line "^-+ End \\(of \\)?forwarded message") +(defvar mm-uu-pgp-begin-signature + "^-----BEGIN PGP SIGNATURE-----") (defvar mm-uu-begin-line nil) -(defconst mm-uu-identifier-alist - '((?% . postscript) (?b . uu) (?: . binhex) (?# . shar) - (?- . forward))) - (defvar mm-dissect-disposition "inline" "The default disposition of uu parts. This can be either \"inline\" or \"attachment\".") +(defvar mm-uu-type-alist + '((postscript + "^%!PS-" + "^%%EOF$" + mm-uu-postscript-extract + nil) + (uu + "^begin[ \t]+[0-7][0-7][0-7][ \t]+" + "^end[ \t]*$" + mm-uu-uu-extract + mm-uu-uu-filename) + (binhex + "^:...............................................................$" + ":$" + mm-uu-binhex-extract + nil + mm-uu-binhex-filename) + (shar + "^#! */bin/sh" + "^exit 0\\|^$" + mm-uu-shar-extract) + (forward +;;; Thanks to Edward J. Sabol and +;;; Peter von der Ah\'e + "^-+ \\(Start of \\)?Forwarded message" + "^-+ End \\(of \\)?forwarded message" + mm-uu-forward-extract + nil + mm-uu-forward-test) + (gnatsweb + "^----gnatsweb-attachment----" + nil + mm-uu-gnatsweb-extract) + (pgp-signed + "^-----BEGIN PGP SIGNED MESSAGE-----" + "^-----END PGP SIGNATURE-----" + mm-uu-pgp-signed-extract + nil + mm-uu-pgp-signed-test) + (pgp-encrypted + "^-----BEGIN PGP MESSAGE-----" + "^-----END PGP MESSAGE-----" + mm-uu-pgp-encrypted-extract + nil + mm-uu-pgp-encrypted-test) + (pgp-key + "^-----BEGIN PGP PUBLIC KEY BLOCK-----" + "^-----END PGP PUBLIC KEY BLOCK-----" + mm-uu-pgp-key-extract + nil + mm-uu-pgp-key-test))) + +(defcustom mm-uu-configure-list nil + "A list of mm-uu configuration. +To disable dissecting shar codes, for instance, add +`(shar . disabled)' to this list." + :type `(repeat (cons + ,(cons 'choice + (mapcar + (lambda (entry) + (cons 'item (car entry))) + mm-uu-type-alist)) + (choice (item disabled)))) + :group 'gnus-article-mime) + +;; functions + +(defsubst mm-uu-type (entry) + (car entry)) + +(defsubst mm-uu-begin-regexp (entry) + (nth 1 entry)) + +(defsubst mm-uu-end-regexp (entry) + (nth 2 entry)) + +(defsubst mm-uu-function-extract (entry) + (nth 3 entry)) + +(defsubst mm-uu-function-1 (entry) + (nth 4 entry)) + +(defsubst mm-uu-function-2 (entry) + (nth 5 entry)) + +(defun mm-uu-copy-to-buffer (from to) + "Copy the contents of the current buffer to a fresh buffer." + (save-excursion + (let ((obuf (current-buffer))) + (set-buffer (generate-new-buffer " *mm-uu*")) + (insert-buffer-substring obuf from to) + (current-buffer)))) + (defun mm-uu-configure-p (key val) (member (cons key val) mm-uu-configure-list)) (defun mm-uu-configure (&optional symbol value) (if symbol (set-default symbol value)) (setq mm-uu-begin-line nil) - (mapcar '(lambda (type) - (if (mm-uu-configure-p type 'disabled) + (mapcar (lambda (entry) + (if (mm-uu-configure-p (mm-uu-type entry) 'disabled) nil (setq mm-uu-begin-line (concat mm-uu-begin-line (if mm-uu-begin-line "\\|") - (symbol-value - (intern (concat "mm-uu-" (symbol-name type) - "-begin-line"))))))) - '(uu postscript binhex shar forward))) - -(defcustom mm-uu-configure-list nil - "A list of mm-uu configuration. -To disable dissecting shar codes, for instance, add -`(shar . disabled)' to this list." - :type '(repeat (cons - (choice (item postscript) - (item uu) - (item binhex) - (item shar) - (item forward)) - (choice (item disabled)))) - :group 'gnus-article-mime - :set 'mm-uu-configure) + (mm-uu-begin-regexp entry))))) + mm-uu-type-alist)) (mm-uu-configure) -;;;### autoload +(eval-when-compile + (defvar file-name) + (defvar start-point) + (defvar end-point) + (defvar entry)) + +(defun mm-uu-uu-filename () + (if (looking-at ".+") + (setq file-name + (let ((nnheader-file-name-translation-alist + '((?/ . ?,) (? . ?_) (?* . ?_) (?$ . ?_)))) + (nnheader-translate-file-chars (match-string 0)))))) + +(defun mm-uu-binhex-filename () + (setq file-name + (ignore-errors + (binhex-decode-region start-point end-point t)))) + +(defun mm-uu-forward-test () + (save-excursion + (goto-char start-point) + (forward-line) + (looking-at "[\r\n]*[a-zA-Z][a-zA-Z0-9-]*:"))) + +(defun mm-uu-postscript-extract () + (mm-make-handle (mm-uu-copy-to-buffer start-point end-point) + '("application/postscript"))) +(defun mm-uu-forward-extract () + (mm-make-handle (mm-uu-copy-to-buffer + (progn (goto-char start-point) (forward-line) (point)) + (progn (goto-char end-point) (forward-line -1) (point))) + '("message/rfc822" (charset . gnus-decoded)))) + +(defun mm-uu-uu-extract () + (mm-make-handle (mm-uu-copy-to-buffer start-point end-point) + (list (or (and file-name + (string-match "\\.[^\\.]+$" + file-name) + (mailcap-extension-to-mime + (match-string 0 file-name))) + "application/octet-stream")) + 'x-uuencode nil + (if (and file-name (not (equal file-name ""))) + (list mm-dissect-disposition + (cons 'filename file-name))))) + +(defun mm-uu-binhex-extract () + (mm-make-handle (mm-uu-copy-to-buffer start-point end-point) + (list (or (and file-name + (string-match "\\.[^\\.]+$" file-name) + (mailcap-extension-to-mime + (match-string 0 file-name))) + "application/octet-stream")) + 'x-binhex nil + (if (and file-name (not (equal file-name ""))) + (list mm-dissect-disposition + (cons 'filename file-name))))) + +(defun mm-uu-shar-extract () + (mm-make-handle (mm-uu-copy-to-buffer start-point end-point) + '("application/x-shar"))) + +(defun mm-uu-gnatsweb-extract () + (save-restriction + (goto-char start-point) + (forward-line) + (narrow-to-region (point) end-point) + (mm-dissect-buffer t))) + +(defun mm-uu-pgp-signed-test () + (and + mml2015-use + (mml2015-clear-verify-function) + (cond + ((eq mm-verify-option 'never) nil) + ((eq mm-verify-option 'always) t) + ((eq mm-verify-option 'known) t) + (t (y-or-n-p "Verify pgp signed part?"))))) + +(defun mm-uu-pgp-signed-extract () + (or (memq 'signed gnus-article-wash-types) + (push 'signed gnus-article-wash-types)) + (let ((buf (mm-uu-copy-to-buffer start-point end-point))) + (with-current-buffer buf + (condition-case err + (funcall (mml2015-clear-verify-function)) + (error + (unless (y-or-n-p (format "%s, continue?" err)) + (kill-buffer buf) + (error "Verify failure.")))) + (goto-char (point-min)) + (if (search-forward "\n\n" nil t) + (delete-region (point-min) (point))) + (if (re-search-forward mm-uu-pgp-begin-signature nil t) + (delete-region (match-beginning 0) (point-max)))) + (mm-make-handle buf + '("text/plain" (charset . gnus-decoded))))) + +(defun mm-uu-pgp-encrypted-test () + (and + mml2015-use + (mml2015-clear-decrypt-function) + (cond + ((eq mm-decrypt-option 'never) nil) + ((eq mm-decrypt-option 'always) t) + ((eq mm-decrypt-option 'known) t) + (t (y-or-n-p "Decrypt pgp encrypted part?"))))) + +(defun mm-uu-pgp-encrypted-extract () + (or (memq 'encrypted gnus-article-wash-types) + (push 'encrypted gnus-article-wash-types)) + (let ((buf (mm-uu-copy-to-buffer start-point end-point))) + (with-current-buffer buf + (condition-case err + (funcall (mml2015-clear-decrypt-function)) + (error + (unless (y-or-n-p (format "%s, continue?" err)) + (kill-buffer buf) + (error "Decrypt failure."))))) + (mm-make-handle buf + '("text/plain" (charset . gnus-decoded))))) + +(defun mm-uu-pgp-key-test () + (and + mml2015-use + (mml2015-clear-snarf-function) + (cond + ((eq mm-snarf-option 'never) nil) + ((eq mm-snarf-option 'always) t) + ((eq mm-snarf-option 'known) t) + (t (y-or-n-p "Snarf pgp signed part?"))))) + +(defun mm-uu-pgp-key-extract () + (let ((buf (mm-uu-copy-to-buffer start-point end-point))) + (with-current-buffer buf + (funcall (mml2015-clear-snarf-function))) + (mm-make-handle buf + '("application/x-pgp-key")))) + +;;;### autoload (defun mm-uu-dissect () "Dissect the current buffer and return a list of uu handles." - (let (text-start start-char end-char - type file-name end-line result text-plain-type - start-char-1 end-char-1 - (case-fold-search t)) + (let ((case-fold-search t) + text-start start-point end-point file-name result + text-plain-type entry func) (save-excursion - (save-restriction - (mail-narrow-to-head) - (goto-char (point-max))) - (forward-line) + (goto-char (point-min)) + (cond + ((looking-at "\n") + (forward-line)) + ((search-forward "\n\n" nil t) + t) + (t (goto-char (point-max)))) ;;; gnus-decoded is a fake charset, which means no further ;;; decoding. (setq text-start (point) text-plain-type '("text/plain" (charset . gnus-decoded))) (while (re-search-forward mm-uu-begin-line nil t) - (setq start-char (match-beginning 0)) - (setq type (cdr (assq (aref (match-string 0) 0) - mm-uu-identifier-alist))) - (setq file-name - (if (and (eq type 'uu) - (looking-at "\\(.+\\)$")) - (and (match-string 1) - (let ((nnheader-file-name-translation-alist - '((?/ . ?,) (? . ?_) (?* . ?_) (?$ . ?_)))) - (nnheader-translate-file-chars (match-string 1)))))) + (setq start-point (match-beginning 0)) + (let ((alist mm-uu-type-alist) + (begin-line (match-string 0))) + (while (not entry) + (if (string-match (mm-uu-begin-regexp (car alist)) begin-line) + (setq entry (car alist)) + (pop alist)))) + (if (setq func (mm-uu-function-1 entry)) + (funcall func)) (forward-line);; in case of failure - (setq start-char-1 (point)) - (setq end-line (symbol-value - (intern (concat "mm-uu-" (symbol-name type) - "-end-line")))) - (when (and (re-search-forward end-line nil t) - (not (eq (match-beginning 0) (match-end 0)))) - (setq end-char-1 (match-beginning 0)) - (forward-line) - (setq end-char (point)) - (when (cond - ((eq type 'binhex) - (setq file-name - (ignore-errors - (binhex-decode-region start-char end-char t)))) - ((eq type 'forward) - (save-excursion - (goto-char start-char-1) - (looking-at "[\r\n]*[a-zA-Z][a-zA-Z0-9-]*:"))) - (t t)) - (if (> start-char text-start) - (push - (mm-make-handle (mm-uu-copy-to-buffer text-start start-char) - text-plain-type) - result)) - (push - (cond - ((eq type 'postscript) - (mm-make-handle (mm-uu-copy-to-buffer start-char end-char) - '("application/postscript"))) - ((eq type 'forward) - (mm-make-handle (mm-uu-copy-to-buffer start-char-1 end-char-1) - '("message/rfc822" (charset . gnus-decoded)))) - ((eq type 'uu) - (mm-make-handle (mm-uu-copy-to-buffer start-char end-char) - (list (or (and file-name - (string-match "\\.[^\\.]+$" - file-name) - (mailcap-extension-to-mime - (match-string 0 file-name))) - "application/octet-stream")) - 'x-uuencode nil - (if (and file-name (not (equal file-name ""))) - (list mm-dissect-disposition - (cons 'filename file-name))))) - ((eq type 'binhex) - (mm-make-handle (mm-uu-copy-to-buffer start-char end-char) - (list (or (and file-name - (string-match "\\.[^\\.]+$" file-name) - (mailcap-extension-to-mime - (match-string 0 file-name))) - "application/octet-stream")) - 'x-binhex nil - (if (and file-name (not (equal file-name ""))) - (list mm-dissect-disposition - (cons 'filename file-name))))) - ((eq type 'shar) - (mm-make-handle (mm-uu-copy-to-buffer start-char end-char) - '("application/x-shar")))) - result) - (setq text-start end-char)))) + (when (and (not (mm-uu-configure-p (mm-uu-type entry) 'disabled)) + (let ((end-line (mm-uu-end-regexp entry))) + (if (not end-line) + (or (setq end-point (point-max)) t) + (prog1 + (re-search-forward end-line nil t) + (forward-line) + (setq end-point (point))))) + (or (not (setq func (mm-uu-function-2 entry))) + (funcall func))) + (if (and (> start-point text-start) + (progn + (goto-char text-start) + (re-search-forward "." start-point t))) + (push + (mm-make-handle (mm-uu-copy-to-buffer text-start start-point) + text-plain-type) + result)) + (push + (funcall (mm-uu-function-extract entry)) + result) + (goto-char (setq text-start end-point)))) (when result - (if (> (point-max) (1+ text-start)) + (if (and (> (point-max) (1+ text-start)) + (save-excursion + (goto-char text-start) + (re-search-forward "." nil t))) (push (mm-make-handle (mm-uu-copy-to-buffer text-start (point-max)) text-plain-type) @@ -225,26 +379,6 @@ To disable dissecting shar codes, for instance, add (setq result (cons "multipart/mixed" (nreverse result)))) result))) -;;;### autoload -(defun mm-uu-test () - "Check whether the current buffer contains uu stuffs." - (save-excursion - (goto-char (point-min)) - (let (type end-line result - (case-fold-search t)) - (while (and mm-uu-begin-line - (not result) (re-search-forward mm-uu-begin-line nil t)) - (forward-line) - (setq type (cdr (assq (aref (match-string 0) 0) - mm-uu-identifier-alist))) - (setq end-line (symbol-value - (intern (concat "mm-uu-" (symbol-name type) - "-end-line")))) - (if (and (re-search-forward end-line nil t) - (not (eq (match-beginning 0) (match-end 0)))) - (setq result t))) - result))) - (provide 'mm-uu) ;;; mm-uu.el ends here diff --git a/lisp/mm-view.el b/lisp/mm-view.el index 9f389ba..d55eb79 100644 --- a/lisp/mm-view.el +++ b/lisp/mm-view.el @@ -158,7 +158,10 @@ ;; This is probably not entirely correct, but ;; makes rfc822 parts with embedded multiparts work. (eq mail-parse-charset 'gnus-decoded)) - (mm-insert-part handle) + (save-restriction + (narrow-to-region (point) (point)) + (mm-insert-part handle) + (goto-char (point-max))) (insert (mm-decode-string (mm-get-part handle) charset))) (when (and (equal type "plain") (equal (cdr (assoc 'format (mm-handle-type handle))) diff --git a/lisp/mml-smime.el b/lisp/mml-smime.el index c979402..b25e36b 100644 --- a/lisp/mml-smime.el +++ b/lisp/mml-smime.el @@ -23,46 +23,15 @@ ;;; Commentary: -;; This support creation of S/MIME parts in MML. - -;; Usage: -;; (mml-smime-setup) -;; -;; Insert an attribute, postprocess=smime-sign (or smime-encrypt), into -;; the mml tag to be signed (or encrypted). -;; -;; It is based on rfc2015.el by Shenghuo Zhu. +;; todo: move s/mime code from mml-sec.el here. ;;; Code: (require 'smime) -;;;###autoload -(defun mml-smime-sign (cont) - ;; FIXME: You have to input the sender. - (when (null smime-keys) - (error "Please use M-x customize RET smime RET to configure SMIME")) - (smime-sign-buffer) - (goto-char (point-min)) - (when (looking-at "^MIME-Version: 1.0") - (forward-line 1) - (delete-region (point-min) (point))) - (goto-char (point-max))) - -;;;###autoload -(defun mml-smime-encrypt (cont) - ;; FIXME: You have to input the receiptant. - ;; FIXME: Should encrypt to myself so I can read it?? - (smime-encrypt-buffer) - (goto-char (point-min)) - (when (looking-at "^MIME-Version: 1.0") - (forward-line 1) - (delete-region (point-min) (point))) - (goto-char (point-max))) - -;;;###autoload -(defun mml-smime-setup () - ) +(defun mml-smime-verify (handle ctl) + (smime-verify-buffer) + handle) (provide 'mml-smime) diff --git a/lisp/mml2015.el b/lisp/mml2015.el index 6d37aba..e4bf3d9 100644 --- a/lisp/mml2015.el +++ b/lisp/mml2015.el @@ -41,15 +41,22 @@ 'gpg))) "The package used for PGP/MIME.") +;; Something is not RFC2015. (defvar mml2015-function-alist '((mailcrypt mml2015-mailcrypt-sign mml2015-mailcrypt-encrypt mml2015-mailcrypt-verify - mml2015-mailcrypt-decrypt) + mml2015-mailcrypt-decrypt + mml2015-mailcrypt-clear-verify + mml2015-mailcrypt-clear-decrypt + mml2015-mailcrypt-clear-snarf) (gpg mml2015-gpg-sign mml2015-gpg-encrypt mml2015-gpg-verify - mml2015-gpg-decrypt)) + mml2015-gpg-decrypt + nil + mml2015-gpg-clear-decrypt + nil)) "Alist of PGP/MIME functions.") (defvar mml2015-result-buffer nil) @@ -62,7 +69,8 @@ (autoload 'mc-pgp-always-sign "mailcrypt") (autoload 'mc-encrypt-generic "mc-toplev") (autoload 'mc-cleanup-recipient-headers "mc-toplev") - (autoload 'mc-sign-generic "mc-toplev")) + (autoload 'mc-sign-generic "mc-toplev") + (autoload 'mc-snarf-keys "mc-toplev")) (eval-when-compile (defvar mc-default-scheme) @@ -70,6 +78,7 @@ (defvar mml2015-decrypt-function 'mailcrypt-decrypt) (defvar mml2015-verify-function 'mailcrypt-verify) +(defvar mml2015-snarf-function 'mc-snarf-keys) (defun mml2015-mailcrypt-decrypt (handle ctl) (let (child handles result) @@ -87,6 +96,12 @@ handles (list handles)))) +(defun mml2015-mailcrypt-clear-decrypt () + (let (result) + (setq result (funcall mml2015-decrypt-function)) + (unless (car result) + (error "Decrypting error.")))) + (defun mml2015-fix-micalg (alg) (upcase (if (and alg (string-match "^pgp-" alg)) @@ -114,6 +129,13 @@ (error "Verify error."))) handle)) +(defun mml2015-mailcrypt-clear-verify () + (unless (funcall mml2015-verify-function) + (error "Verify error."))) + +(defun mml2015-mailcrypt-clear-snarf () + (funcall mml2015-snarf-function)) + (defun mml2015-mailcrypt-sign (cont) (mc-sign-generic (message-options-get 'message-sender) nil nil nil nil) @@ -214,6 +236,12 @@ (let ((mml2015-decrypt-function 'mml2015-gpg-decrypt-1)) (mml2015-mailcrypt-decrypt handle ctl))) +(defun mml2015-gpg-clear-decrypt () + (let (result) + (setq result (mml2015-gpg-decrypt-1)) + (unless (car result) + (error "Decrypting error.")))) + (defun mml2015-gpg-verify (handle ctl) (let (part message signature) (unless (setq part (mm-find-raw-part-by-type @@ -311,6 +339,15 @@ (gnus-get-buffer-create "*MML2015 Result*")) nil)) +(defsubst mml2015-clear-snarf-function () + (nth 7 (assq mml2015-use mml2015-function-alist))) + +(defsubst mml2015-clear-decrypt-function () + (nth 6 (assq mml2015-use mml2015-function-alist))) + +(defsubst mml2015-clear-verify-function () + (nth 5 (assq mml2015-use mml2015-function-alist))) + ;;;###autoload (defun mml2015-decrypt (handle ctl) (mml2015-clean-buffer) diff --git a/lisp/nnheader.el b/lisp/nnheader.el index 922a9ba..3e3741d 100644 --- a/lisp/nnheader.el +++ b/lisp/nnheader.el @@ -950,7 +950,7 @@ without formatting." (or (not (numberp gnus-verbose-backends)) (<= level gnus-verbose-backends))) -(defvar nnheader-pathname-coding-system 'binary +(defvar nnheader-pathname-coding-system 'iso-8859-1 "*Coding system for pathname.") (defun nnheader-group-pathname (group dir &optional file) diff --git a/lisp/nnmail.el b/lisp/nnmail.el index 7255b74..88c704f 100644 --- a/lisp/nnmail.el +++ b/lisp/nnmail.el @@ -470,7 +470,7 @@ parameter. It should return nil, `warn' or `delete'." nnheader-text-coding-system "Coding system used in reading inbox") -(defvar nnmail-pathname-coding-system 'binary +(defvar nnmail-pathname-coding-system 'iso-8859-1 "*Coding system for pathname.") (defun nnmail-find-file (file) diff --git a/lisp/nnoo.el b/lisp/nnoo.el index 44a0f83..fc9adb8 100644 --- a/lisp/nnoo.el +++ b/lisp/nnoo.el @@ -302,6 +302,20 @@ All functions will return nil and report an error." (&rest args) (nnheader-report ',backend ,(format "%s-%s not implemented" backend function)))))))) + +(defun nnoo-set (server &rest args) + (let ((parents (nnoo-parents (car server))) + (nnoo-parent-backend (car server))) + (while parents + (nnoo-change-server (caar parents) + (cadr server) + (cdar parents)) + (pop parents))) + (nnoo-change-server (car server) + (cadr server) (cddr server)) + (while args + (set (pop args) (pop args)))) + (provide 'nnoo) ;;; nnoo.el ends here. diff --git a/lisp/nntp.el b/lisp/nntp.el index 5d7afc5..b1b0ce9 100644 --- a/lisp/nntp.el +++ b/lisp/nntp.el @@ -1172,7 +1172,9 @@ password contained in '~/.nntp-authinfo'." (delete-char 2)) ;; Delete status line. (goto-char (point-min)) - (delete-region (point) (progn (forward-line 1) (point))) + (while (looking-at "[1-5][0-9][0-9] .*\n") + ;; For some unknown reason, there are more than one status lines. + (delete-region (point) (progn (forward-line 1) (point)))) ;; Remove "." -> ".." encoding. (while (search-forward "\n.." nil t) (delete-char -1)))) diff --git a/lisp/rfc2231.el b/lisp/rfc2231.el index 2881706..6ef6990 100644 --- a/lisp/rfc2231.el +++ b/lisp/rfc2231.el @@ -150,7 +150,8 @@ These look like \"us-ascii'en-us'This%20is%20%2A%2A%2Afun%2A%2A%2A\"." (string-to-number (buffer-substring (point) (+ (point) 2)) 16) (delete-region (1- (point)) (+ (point) 2))))) ;; Encode using the charset, if any. - (when (and (> (length elems) 1) + (when (and (mm-multibyte-p) + (> (length elems) 1) (not (equal (intern (car elems)) 'us-ascii))) (mm-decode-coding-region (point-min) (point-max) (intern (car elems)))) diff --git a/todo b/todo index 21d3e57..2e56251 100644 --- a/todo +++ b/todo @@ -1,6 +1,32 @@ ;; Also know as the "wish list". Some are done. For the others, no ;; promise when to be implemented. +* Parsing of the common list confirmation requests so that Gnus can + prepare the response with a single command. Including LISTSERV + periodic ping messages and the like. + +* Parsing of the various List-* headers to enable automatic commands + like "send help message," "send unsubscribe message," and the like. + + [done, see gnus-ml.el] + +* Parsing of the subscription notice to stash away details like what + address you're subscribed to the list under (and automatically send + mail to the list using that address, when you send mail inside the list + group), what address to mail to unsubscribe, and the list info message + if available. Hitting the "get FAQ" command inside a mailing list + group should display that stashed copy of the info message. + +* Some help in coming up with good split rules for mailing lists, as + automated as possible. Splitting on To and Cc is almost always not + what I want, since it can misfile messages and since if I'm cc'd on + list mail I want to get both copies, one in my personal mailbox and one + in the list mailbox. I know other people handle it other ways, but I + prefer it that way. Accordingly, some way to semi-automatically + generate split rules based on Sender, Mailing-List, Return-Path, + X-Loop, and all of the other random headers that often work would be + very cool. + * Support for zipped folders for all backends this makes sense for. Most likely using jka-compr. (It has been suggested that this do work but I think it should be verified for all backends.) @@ -1233,6 +1259,8 @@ exceeding lisp nesting on huge groups. * (nnoo-set SERVER VARIABLE VALUE) + [done] + * nn*-spool-methods * interrupitng agent fetching of articles should save articles.