+++ /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.4.2 2001-07-15 23:22:50 yamaoka 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
projects / elisp / gnus.git- / blobdiff