--- /dev/null
+;;; 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)
--- /dev/null
+;;; gpg-ring.el --- Major mode for editing GnuPG key rings.
+
+;; Copyright (C) 2000 RUS-CERT, University Of Stuttgart
+
+;; Author: Florian Weimer <Florian.Weimer@RUS.Uni-Stuttgart.DE>
+;; Maintainer: Florian Weimer <Florian.Weimer@RUS.Uni-Stuttgart.DE>
+;; 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.
+
+
+\f
+;;;; 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
--- /dev/null
+;;; gpg.el --- Interface to GNU Privacy Guard
+
+;; Copyright (C) 2000 RUS-CERT, University Of Stuttgart
+
+;; Author: Florian Weimer <Florian.Weimer@RUS.Uni-Stuttgart.DE>
+;; Maintainer: Florian Weimer <Florian.Weimer@RUS.Uni-Stuttgart.DE>
+;; 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).
+
+\f
+;;;; 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)
+
+\f
+;;;; 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))))
+
+\f
+;;;; 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)))
+
+\f
+;;;; 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
--- /dev/null
+;;; md5.el -- MD5 Message Digest Algorithm
+;;; Gareth Rees <gdr11@cl.cam.ac.uk>
+
+;; 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 ----------------------------------------------------------
+2000-11-05 Simon Josefsson <sj@extundo.com>
+
+ * 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 <zsh@cs.rochester.edu>
+
+ * mm-view.el (mm-inline-text): Move point to the end of inserted text.
+
+2000-11-04 19:07:08 ShengHuo ZHU <zsh@cs.rochester.edu>
+
+ * 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 <zsh@cs.rochester.edu>
+
+ * 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 <zsh@cs.rochester.edu>
+
+ * base64.el, md5.el: Moved to contrib directory.
+
+2000-11-04 11:13:56 ShengHuo ZHU <zsh@cs.rochester.edu>
+
+ * gnus-sum.el (gnus-summary-search-article-forward): Don't move
+ the last article when search.
+
+2000-11-04 10:34:29 ShengHuo ZHU <zsh@cs.rochester.edu>
+
+ * nnheader.el (nnheader-pathname-coding-system): Default iso-8859-1.
+ * nnmail.el (nnmail-pathname-coding-system): Ditto.
+
+2000-09-29 David Edmondson <dme@thus.net>
+
+ One-line patch.
+
+ * message.el (message-newline-and-reformat): Typo.
+
+2000-11-04 10:11:05 ShengHuo ZHU <zsh@cs.rochester.edu>
+
+ * rfc2231.el (rfc2231-decode-encoded-string): Test mm-multibyte-p.
+
+2000-11-04 09:53:42 ShengHuo ZHU <zsh@cs.rochester.edu>
+
+ * nntp.el (nntp-decode-text): Delete bogus status lines.
+
+2000-11-03 Stefan Monnier <monnier@cs.yale.edu>
+
+ * 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 <zsh@cs.rochester.edu>
+
+ * nnoo.el (nnoo-set): New function.
+
+2000-11-04 ShengHuo Zhu <zsh@cs.rochester.edu>
+
+ * gpg.el, gpg-ring.el: Moved to contrib directory.
+
2000-11-04 Simon Josefsson <sj@extundo.com>
* nnimap.el (nnimap-split-inbox): Typo.
+++ /dev/null
-;;; 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)
(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.
(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
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."
+++ /dev/null
-;;; gpg-ring.el --- Major mode for editing GnuPG key rings.
-
-;; Copyright (C) 2000 RUS-CERT, University Of Stuttgart
-
-;; Author: Florian Weimer <Florian.Weimer@RUS.Uni-Stuttgart.DE>
-;; Maintainer: Florian Weimer <Florian.Weimer@RUS.Uni-Stuttgart.DE>
-;; 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.
-
-
-\f
-;;;; 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
+++ /dev/null
-;;; gpg.el --- Interface to GNU Privacy Guard
-
-;; Copyright (C) 2000 RUS-CERT, University Of Stuttgart
-
-;; Author: Florian Weimer <Florian.Weimer@RUS.Uni-Stuttgart.DE>
-;; Maintainer: Florian Weimer <Florian.Weimer@RUS.Uni-Stuttgart.DE>
-;; 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).
-
-\f
-;;;; 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)
-
-\f
-;;;; 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))))
-
-\f
-;;;; 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)))
-
-\f
-;;;; 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
+++ /dev/null
-;;; md5.el -- MD5 Message Digest Algorithm
-;;; Gareth Rees <gdr11@cl.cam.ac.uk>
-
-;; 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 ----------------------------------------------------------
(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))
(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"))
(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))
(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)
(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)
(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.
(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.
(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)
(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
(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))
(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)
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
(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."
;; Copyright (c) 1998, 1999, 2000 Free Software Foundation, Inc.
;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
-;; Keywords: postscript uudecode binhex shar forward news
+;; Keywords: postscript uudecode binhex shar forward gnatsweb pgp
;; This file is part of GNU Emacs.
(require 'nnheader)
(require 'mm-decode)
(require 'gnus-mailcap)
+(require 'mml2015)
(eval-and-compile
(autoload 'binhex-decode-region "binhex")
(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
(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
(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 <sabol@alderaan.gsfc.nasa.gov> and
-;;; Peter von der Ah\'e <pahe@daimi.au.dk>
-(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 <sabol@alderaan.gsfc.nasa.gov> and
+;;; Peter von der Ah\'e <pahe@daimi.au.dk>
+ "^-+ \\(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)
(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
;; 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)))
;;; 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)
'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)
(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)
(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)
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))
(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)
(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
(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)
(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)
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)
(&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.
(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))))
(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))))
;; 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.)
* (nnoo-set SERVER VARIABLE VALUE)
+ [done]
+
* nn*-spool-methods
* interrupitng agent fetching of articles should save articles.
projects / elisp / gnus.git- / commitdiff