1 ;;; epa.el --- EasyPG Assistant, GUI of EasyPG
2 ;; Copyright (C) 2006 Daiki Ueno
4 ;; Author: Daiki Ueno <ueno@unixuser.org>
5 ;; Keywords: PGP, GnuPG
7 ;; This file is part of EasyPG.
9 ;; This program is free software; you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation; either version 2, or (at your option)
14 ;; This program is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details.
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs; see the file COPYING. If not, write to the
21 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
22 ;; Boston, MA 02110-1301, USA.
29 (eval-when-compile (require 'wid-edit))
32 "EasyPG Assistant, GUI of EasyPG."
35 (defgroup epa-faces nil
39 (defvar epa-buffer nil)
41 (defface epa-validity-high-face
42 '((((class color) (background dark))
43 (:foreground "PaleTurquoise" :bold t))
46 "Face used for displaying the high validity."
48 (defvar epa-validity-high-face 'epa-validity-high-face)
50 (defface epa-validity-medium-face
51 '((((class color) (background dark))
52 (:foreground "PaleTurquoise" :italic t))
55 "Face used for displaying the medium validity."
57 (defvar epa-validity-medium-face 'epa-validity-medium-face)
59 (defface epa-validity-low-face
62 "Face used for displaying the low validity."
64 (defvar epa-validity-low-face 'epa-validity-low-face)
66 (defface epa-validity-disabled-face
68 (:italic t :inverse-video t)))
69 "Face used for displaying the disabled validity."
71 (defvar epa-validity-disabled-face 'epa-validity-disabled-face)
73 (defface epa-string-face
76 (:foreground "lightyellow"))
79 (:foreground "blue4"))
82 "Face used for displaying the string."
84 (defvar epa-string-face 'epa-string-face)
86 (defface epa-field-name-face
87 '((((class color) (background dark))
88 (:foreground "PaleTurquoise" :bold t))
90 "Face for the name of the attribute field."
92 (defvar epa-field-name-face 'epa-field-name-face)
94 (defface epa-field-body-face
95 '((((class color) (background dark))
96 (:foreground "turquoise" :italic t))
98 "Face for the body of the attribute field."
100 (defvar epa-field-body-face 'epa-field-body-face)
102 (defcustom epa-validity-face-alist
103 '((?o . epa-validity-disabled-face)
104 (?i . epa-validity-disabled-face)
105 (?d . epa-validity-disabled-face)
106 (?r . epa-validity-disabled-face)
107 (?e . epa-validity-disabled-face)
108 (?- . epa-validity-low-face)
109 (?q . epa-validity-low-face)
110 (?n . epa-validity-low-face)
111 (?m . epa-validity-medium-face)
112 (?f . epa-validity-high-face)
113 (?u . epa-validity-high-face))
114 "An alist mapping marks on epa-keys-buffer to faces."
118 (defcustom epa-font-lock-keywords
119 '(("^[* ]\\(\\([oidreqnmfu-]\\) .*\\)"
120 (1 (cdr (assq (aref (match-string 2) 0)
121 epa-validity-face-alist))))
122 ("^\t\\([^\t:]+:\\)[ \t]*\\(.*\\)$"
123 (1 epa-field-name-face)
124 (2 epa-field-body-face)))
125 "Default expressions to addon in epa-mode."
126 :type '(repeat (list string))
129 (defconst epa-pubkey-algorithm-letter-alist
137 (defvar epa-keys-buffer nil)
138 (defvar epa-key-buffer-alist nil)
141 (defvar epa-keys-mode-map
142 (let ((keymap (make-sparse-keymap)))
143 (define-key keymap "m" 'epa-mark)
144 (define-key keymap "u" 'epa-unmark)
145 (define-key keymap "n" 'next-line)
146 (define-key keymap "p" 'previous-line)
147 (define-key keymap " " 'scroll-up)
148 (define-key keymap [delete] 'scroll-down)
149 (define-key keymap "q" 'bury-buffer)
152 (defun epa-keys-mode ()
153 "Major mode for `epa-list-keys'."
154 (kill-all-local-variables)
155 (buffer-disable-undo)
156 (setq major-mode 'epa-keys-mode
160 (use-local-map epa-keys-mode-map)
161 (set-keymap-parent (current-local-map) widget-keymap)
162 (make-local-variable 'font-lock-defaults)
163 (setq font-lock-defaults '(epa-font-lock-keywords t))
164 ;; In XEmacs, auto-initialization of font-lock is not effective
165 ;; if buffer-file-name is not set.
166 (font-lock-set-defaults)
168 (run-hooks 'epa-keys-mode-hook))
170 (defvar epa-key-mode-map
171 (let ((keymap (make-sparse-keymap)))
172 (define-key keymap "q" 'bury-buffer)
175 (defun epa-key-mode ()
176 "Major mode for `epa-show-key'."
177 (kill-all-local-variables)
178 (buffer-disable-undo)
179 (setq major-mode 'epa-key-mode
183 (use-local-map epa-key-mode-map)
184 (make-local-variable 'font-lock-defaults)
185 (setq font-lock-defaults '(epa-font-lock-keywords t))
186 ;; In XEmacs, auto-initialization of font-lock is not effective
187 ;; if buffer-file-name is not set.
188 (font-lock-set-defaults)
189 (run-hooks 'epa-key-mode-hook))
192 (defun epa-list-keys (&optional name)
193 (interactive "sPattern: ")
194 (unless (and epa-keys-buffer
195 (buffer-live-p epa-keys-buffer))
196 (setq epa-keys-buffer (generate-new-buffer "*Keys*")))
197 (set-buffer epa-keys-buffer)
199 (epa-list-keys-1 name)
201 (goto-char (point-min))
202 (pop-to-buffer (current-buffer)))
204 (defun epa-list-keys-1 (name)
205 (let ((inhibit-read-only t)
207 keys point primary-sub-key primary-user-id)
208 (setq keys (epg-list-keys))
211 primary-sub-key (car (epg-key-sub-key-list (car keys)))
212 primary-user-id (car (epg-key-user-id-list (car keys))))
213 (insert " " (or (char-to-string
214 (car (rassq (epg-sub-key-validity primary-sub-key)
215 epg-key-validity-alist)))
218 :tag (epg-sub-key-id primary-sub-key)
219 :notify 'epa-show-key-notify
221 (insert " " (epg-user-id-name primary-user-id) "\n")
222 (put-text-property point (point) 'epa-key (car keys))
223 (setq keys (cdr keys)))))
225 (defun epa-ask-keys (prompt function &optional names &rest args)
226 (unless (and epa-keys-buffer
227 (buffer-live-p epa-keys-buffer))
228 (setq epa-keys-buffer (generate-new-buffer "*Keys*")))
229 (let ((buffer (current-buffer))
230 (inhibit-read-only t)
232 (set-buffer epa-keys-buffer)
235 (widget-create 'push-button
237 :notify (lambda (widget &rest ignore)
238 (let ((callback (widget-value widget))
240 (while (re-search-forward "^\\*" nil t)
241 (if (setq key (get-text-property (point)
243 (setq keys (cons key keys))))
244 (set-buffer (car callback))
245 (apply (car (cdr callback)) keys
246 (cdr (cdr callback)))))
247 (cons buffer (cons function args)))
251 (epa-list-keys-1 (car names))
252 (setq names (cdr names)))
253 (epa-list-keys-1 nil))
255 (goto-char (point-min))
256 (pop-to-buffer (current-buffer))))
258 (defun epa-show-key (key)
259 (let* ((primary-sub-key (car (epg-key-sub-key-list key)))
260 (entry (assoc (epg-sub-key-id primary-sub-key)
261 epa-key-buffer-alist))
262 (inhibit-read-only t)
266 (setq entry (cons (epg-sub-key-id primary-sub-key) nil)
267 epa-key-buffer-alist (cons entry epa-key-buffer-alist)))
268 (unless (and (cdr entry)
269 (buffer-live-p (cdr entry)))
270 (setcdr entry (generate-new-buffer
271 (format "*Key*%s" (epg-sub-key-id primary-sub-key)))))
272 (set-buffer (cdr entry))
273 (make-local-variable 'epa-key)
276 (setq pointer (epg-key-user-id-list key))
280 (car (rassq (epg-user-id-validity (car pointer))
281 epg-key-validity-alist)))
283 (epg-user-id-name (car pointer))
285 (setq pointer (cdr pointer)))
286 (setq pointer (epg-key-sub-key-list key))
290 (car (rassq (epg-sub-key-validity (car pointer))
291 epg-key-validity-alist)))
293 (epg-sub-key-id (car pointer))
296 (epg-sub-key-length (car pointer)))
298 (cdr (assq (epg-sub-key-algorithm (car pointer))
299 epg-pubkey-algorithm-alist))
301 (epg-sub-key-creation-time (car pointer))
302 (if (epg-sub-key-expiration-time (car pointer))
303 (format "\n\tExpires: %s" (epg-sub-key-expiration-time
307 (mapconcat #'symbol-name
308 (epg-sub-key-capability (car pointer))
311 (epg-sub-key-fingerprint (car pointer))
313 (setq pointer (cdr pointer)))
314 (goto-char (point-min))
315 (pop-to-buffer (current-buffer))
318 (defun epa-show-key-notify (widget &rest ignore)
319 (epa-show-key (widget-value widget)))
322 "Mark the current line."
324 (let ((inhibit-read-only t)
328 (setq properties (text-properties-at (point)))
331 (set-text-properties (1- (point)) (point) properties)
335 "Unmark the current line."
337 (let ((inhibit-read-only t)
341 (setq properties (text-properties-at (point)))
344 (set-text-properties (1- (point)) (point) properties)