X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=epa.el;h=fa1f6bf37c55d4d16450f4e6a3daf5b504c6b726;hb=f4a0e4453626050f816bce237441b2c5bd511386;hp=73b867e7afcd39b12b86161c8b21a602de0ed423;hpb=36ea9cba97ee1214fba7f1f0b7176227f334ac16;p=elisp%2Fepg.git

diff --git a/epa.el b/epa.el
index 73b867e..fa1f6bf 100644
--- a/epa.el
+++ b/epa.el
@@ -1,49 +1,74 @@
+;;; epa.el --- EasyPG Assistant, GUI of EasyPG
+;; Copyright (C) 2006 Daiki Ueno
+
+;; Author: Daiki Ueno <ueno@unixuser.org>
+;; Keywords: PGP, GnuPG
+
+;; This file is part of EasyPG.
+
+;; This program 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.
+
+;; This program 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., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Code:
+
 (require 'epg)
 (require 'font-lock)
+(require 'widget)
+(eval-when-compile (require 'wid-edit))
 
 (defgroup epa nil
-  "EasyPG Assistant, GUI for EasyPG."
+  "EasyPG Assistant, GUI of EasyPG."
   :group 'epg)
 
 (defgroup epa-faces nil
   "Faces for epa-mode."
   :group 'epa)
 
-(defvar epa-buffer nil)
-
-(defface epa-trust-full-face
+(defface epa-validity-high-face
   '((((class color) (background dark))
      (:foreground "PaleTurquoise" :bold t))
     (t
      (:bold t)))
-  "Face used for displaying the trust-full addon."
+  "Face used for displaying the high validity."
   :group 'epa-faces)
-(defvar epa-trust-full-face 'epa-trust-full-face)
+(defvar epa-validity-high-face 'epa-validity-high-face)
 
-(defface epa-trust-disabled-face
+(defface epa-validity-medium-face
   '((((class color) (background dark))
      (:foreground "PaleTurquoise" :italic t))
     (t
      ()))
-  "Face used for displaying the disabled trust."
+  "Face used for displaying the medium validity."
   :group 'epa-faces)
-(defvar epa-trust-disabled-face 'epa-trust-disabled-face)
+(defvar epa-validity-medium-face 'epa-validity-medium-face)
 
-(defface epa-trust-unknown-face
+(defface epa-validity-low-face
   '((t
      (:italic t)))
-  "Face used for displaying the trust-unknown addon."
+  "Face used for displaying the low validity."
   :group 'epa-faces)
-(defvar epa-trust-unknown-face 'epa-trust-unknown-face)
+(defvar epa-validity-low-face 'epa-validity-low-face)
 
-(defface epa-trust-marginal-face
+(defface epa-validity-disabled-face
   '((t
      (:italic t :inverse-video t)))
-  "Face used for displaying the trust-marginal addon."
+  "Face used for displaying the disabled validity."
   :group 'epa-faces)
-(defvar epa-trust-marginal-face 'epa-trust-marginal-face)
+(defvar epa-validity-disabled-face 'epa-validity-disabled-face)
 
-(defface epa-user-id-face
+(defface epa-string-face
   '((((class color)
       (background dark))
      (:foreground "lightyellow"))
@@ -52,268 +77,271 @@
      (:foreground "blue4"))
     (t
      ()))
-  "Face used for displaying the user-id addon."
+  "Face used for displaying the string."
   :group 'epa-faces)
-(defvar epa-user-id-face 'epa-user-id-face)
+(defvar epa-string-face 'epa-string-face)
+
+(defface epa-field-name-face
+  '((((class color) (background dark))
+     (:foreground "PaleTurquoise" :bold t))
+    (t (:bold t)))
+  "Face for the name of the attribute field."
+  :group 'epa)
+(defvar epa-field-name-face 'epa-field-name-face)
+
+(defface epa-field-body-face
+  '((((class color) (background dark))
+     (:foreground "turquoise" :italic t))
+    (t (:italic t)))
+  "Face for the body of the attribute field."
+  :group 'epa)
+(defvar epa-field-body-face 'epa-field-body-face)
 
 (defcustom epa-validity-face-alist
-  '((?o . epa-trust-unknown-face)
-    (?i . epa-trust-disabled-face)
-    (?d . epa-trust-disabled-face)
-    (?r . epa-trust-disabled-face)
-    (?e . epa-trust-disabled-face)
-    (?- . epa-trust-unknown-face)
-    (?q . epa-trust-unknown-face)
-    (?n . epa-trust-disabled-face)
-    (?m . epa-trust-marginal-face)
-    (?f . epa-trust-full-face)
-    (?u . epa-trust-full-face)
-    (?  . epa-trust-full-face))
-  "An alist mapping marks on epa-buffer to faces."
+  '((?o . epa-validity-disabled-face)
+    (?i . epa-validity-disabled-face)
+    (?d . epa-validity-disabled-face)
+    (?r . epa-validity-disabled-face)
+    (?e . epa-validity-disabled-face)
+    (?- . epa-validity-low-face)
+    (?q . epa-validity-low-face)
+    (?n . epa-validity-low-face)
+    (?m . epa-validity-medium-face)
+    (?f . epa-validity-high-face)
+    (?u . epa-validity-high-face))
+  "An alist mapping marks on epa-keys-buffer to faces."
   :type 'list
   :group 'epa)
 
 (defcustom epa-font-lock-keywords
-  '(("^[* ]\\([-oidreqnmfu ]\\)\\s-+\\(\\S-+\\)\\s-+\\(.*\\)"
-     (2 (cdr (assq (aref (match-string 1) 0)
-		   epa-validity-face-alist)))
-     (3 epa-user-id-face)))
+  '(("^[* ]\\(\\([oidreqnmfu-]\\) .*\\)"
+     (1 (cdr (assq (aref (match-string 2) 0)
+		   epa-validity-face-alist))))
+    ("^\t\\([^\t:]+:\\)[ \t]*\\(.*\\)$"
+     (1 epa-field-name-face)
+     (2 epa-field-body-face)))
   "Default expressions to addon in epa-mode."
   :type '(repeat (list string))
   :group 'epa)
 
-(defvar epa-mode-map
+(defconst epa-pubkey-algorithm-letter-alist
+  '((1 . ?R)
+    (2 . ?r)
+    (3 . ?s)
+    (16 . ?g)
+    (17 . ?D)
+    (20 . G)))
+
+(defvar epa-keys-buffer nil)
+(defvar epa-key-buffer-alist nil)
+(defvar epa-key nil)
+
+(defvar epa-keys-mode-map
   (let ((keymap (make-sparse-keymap)))
-    (define-key keymap "m" 'epa-command-mark-key)
-    (define-key keymap "u" 'epa-command-unmark-key)
-    (define-key keymap "n" 'epa-command-next-line)
+    (define-key keymap "m" 'epa-mark)
+    (define-key keymap "u" 'epa-unmark)
+    (define-key keymap "n" 'next-line)
     (define-key keymap "p" 'previous-line)
-    (define-key keymap "e" 'epa-command-encrypt-file)
-    (define-key keymap "s" 'epa-command-sign-file)
     (define-key keymap " " 'scroll-up)
     (define-key keymap [delete] 'scroll-down)
     (define-key keymap "q" 'bury-buffer)
     keymap))
 
-(defun epa-mode ()
-  "Major mode for displaying addon list.
-All normal editing commands are turned off."
+(defun epa-keys-mode ()
+  "Major mode for `epa-list-keys'."
   (kill-all-local-variables)
   (buffer-disable-undo)
-  (setq major-mode 'epa-mode
-	mode-name "EPA"
+  (setq major-mode 'epa-keys-mode
+	mode-name "Keys"
 	truncate-lines t
 	buffer-read-only t)
-  (use-local-map epa-mode-map)
+  (use-local-map epa-keys-mode-map)
+  (set-keymap-parent (current-local-map) widget-keymap)
   (make-local-variable 'font-lock-defaults)
   (setq font-lock-defaults '(epa-font-lock-keywords t))
   ;; In XEmacs, auto-initialization of font-lock is not effective
   ;; if buffer-file-name is not set.
   (font-lock-set-defaults)
-  (make-local-variable 'epa-marked-keys)
-  (run-hooks 'epa-mode-hook))
+  (widget-setup)
+  (run-hooks 'epa-keys-mode-hook))
 
-(defun epa ()
-  (interactive)
-  (unless epa-buffer
-    (setq epa-buffer (generate-new-buffer "*EPA*")))
-  (set-buffer epa-buffer)
-  (epa-mode)
+(defvar epa-key-mode-map
+  (let ((keymap (make-sparse-keymap)))
+    (define-key keymap "q" 'bury-buffer)
+    keymap))
+
+(defun epa-key-mode ()
+  "Major mode for `epa-show-key'."
+  (kill-all-local-variables)
+  (buffer-disable-undo)
+  (setq major-mode 'epa-key-mode
+	mode-name "Key"
+	truncate-lines t
+	buffer-read-only t)
+  (use-local-map epa-key-mode-map)
+  (make-local-variable 'font-lock-defaults)
+  (setq font-lock-defaults '(epa-font-lock-keywords t))
+  ;; In XEmacs, auto-initialization of font-lock is not effective
+  ;; if buffer-file-name is not set.
+  (font-lock-set-defaults)
+  (run-hooks 'epa-key-mode-hook))
+
+;;;###autoload
+(defun epa-list-keys (&optional name)
+  (interactive "sPattern: ")
+  (unless (and epa-keys-buffer
+	       (buffer-live-p epa-keys-buffer))
+    (setq epa-keys-buffer (generate-new-buffer "*Keys*")))
+  (set-buffer epa-keys-buffer)
+  (erase-buffer)
+  (epa-list-keys-1 name)
+  (epa-keys-mode)
+  (goto-char (point-min))
+  (pop-to-buffer (current-buffer)))
+
+(defun epa-list-keys-1 (name)
   (let ((inhibit-read-only t)
 	buffer-read-only
-	configuration pointer entry point)
+	keys point primary-sub-key primary-user-id)
+    (setq keys (epg-list-keys))
+    (while keys
+      (setq point (point)
+	    primary-sub-key (car (epg-key-sub-key-list (car keys)))
+	    primary-user-id (car (epg-key-user-id-list (car keys))))
+      (insert " " (or (char-to-string
+		       (car (rassq (epg-sub-key-validity primary-sub-key)
+				   epg-key-validity-alist)))
+		      " ") " ")
+      (widget-create 'link 
+		     :tag (epg-sub-key-id primary-sub-key)
+		     :notify 'epa-show-key-notify
+		     (car keys))
+      (insert " " (epg-user-id-name primary-user-id) "\n")
+      (put-text-property point (point) 'epa-key (car keys))
+      (setq keys (cdr keys)))))
+
+(defun epa-select-keys (prompt &optional names)
+  (unless (and epa-keys-buffer
+	       (buffer-live-p epa-keys-buffer))
+    (setq epa-keys-buffer (generate-new-buffer "*Keys*")))
+  (let ((inhibit-read-only t)
+	buffer-read-only)
+    (set-buffer epa-keys-buffer)
     (erase-buffer)
-    (insert "EasyPG Assistant\n\n")
-    (setq configuration (epg-configuration))
-    (if (setq entry (assq 'version configuration))
-	(insert (format "GnuPG %s\n" (cdr entry))))
-    (if (setq entry (assq 'pubkey configuration))
-	(insert (format "Pubkey: %s\n"
-			(mapconcat
-			 (lambda (algorithm)
-			   (if (setq entry
-				     (assq algorithm
-					   epg-pubkey-algorithm-alist))
-			       (cdr entry)
-			     (format "(unknown: %d)" algorithm)))
-			 (cdr entry) ", "))))
-    (if (setq entry (assq 'cipher configuration))
-	(insert (format "Cipher: %s\n"
-			(mapconcat
-			 (lambda (algorithm)
-			   (if (setq entry
-				     (assq algorithm
-					   epg-cipher-algorithm-alist))
-			       (cdr entry)
-			     (format "(unknown: %d)" algorithm)))
-			 (cdr entry) ", "))))
-    (if (setq entry (assq 'digest configuration))
-	(insert (format "Hash: %s\n"
-			(mapconcat
-			 (lambda (algorithm)
-			   (if (setq entry
-				     (assq algorithm
-					   epg-digest-algorithm-alist))
-			       (cdr entry)
-			     (format "(unknown: %d)" algorithm)))
-			 (cdr entry) ", "))))
-    (if (setq entry (assq 'compress configuration))
-	(insert (format "Compression: %s\n"
-			(mapconcat
-			 (lambda (algorithm)
-			   (if (setq entry
-				     (assq algorithm
-					   epg-compress-algorithm-alist))
-			       (cdr entry)
-			     (format "(unknown: %d)" algorithm)))
-			 (cdr entry) ", "))))
-    (insert "\nSecret keys:\n\n")
-    (setq pointer (epg-list-keys nil t))
+    (insert prompt "\n\n"
+	    (substitute-command-keys "\\[exit-recursive-edit] to exit.")
+	    "\n\n")
+    (if names
+	(while names
+	  (epa-list-keys-1 (car names))
+	  (setq names (cdr names)))
+      (epa-list-keys-1 nil))
+    (epa-keys-mode)
+    (goto-char (point-min))
+    (pop-to-buffer (current-buffer))
+    (unwind-protect
+	(progn
+	  (recursive-edit)
+	  (save-excursion
+	    (set-buffer epa-keys-buffer)
+	    (goto-char (point-min))
+	    (let (keys key)
+	      (while (re-search-forward "^\\*" nil t)
+		(if (setq key (get-text-property (match-beginning 0) 'epa-key))
+		    (setq keys (cons key keys))))
+	      (nreverse keys))))
+      (if (get-buffer-window epa-keys-buffer)
+	  (delete-window (get-buffer-window epa-keys-buffer))))))
+
+(defun epa-show-key (key)
+  (let* ((primary-sub-key (car (epg-key-sub-key-list key)))
+	 (entry (assoc (epg-sub-key-id primary-sub-key)
+		       epa-key-buffer-alist))
+	 (inhibit-read-only t)
+	 buffer-read-only
+	 pointer)
+    (unless entry
+      (setq entry (cons (epg-sub-key-id primary-sub-key) nil)
+	    epa-key-buffer-alist (cons entry epa-key-buffer-alist)))
+    (unless (and (cdr entry)
+		 (buffer-live-p (cdr entry)))
+      (setcdr entry (generate-new-buffer
+		     (format "*Key*%s" (epg-sub-key-id primary-sub-key)))))
+    (set-buffer (cdr entry))
+    (make-local-variable 'epa-key)
+    (setq epa-key key)
+    (erase-buffer)
+    (setq pointer (epg-key-user-id-list key))
     (while pointer
-      (setq point (point))
-      (setq entry (cdr (assq 'sec (car pointer))))
-      (setq key-id (cdr (assq 'key-id entry)))
-      (insert (format "   %s %s\n"
-		      key-id
-		      (cdr (assq 'user-id (assq 'uid (car pointer))))))
-      (put-text-property point (point) 'epa-key-id key-id)
-      (put-text-property point (point) 'epa-key-secret t)
+      (insert " "
+	      (char-to-string
+	       (car (rassq (epg-user-id-validity (car pointer))
+			   epg-key-validity-alist)))
+	      " "
+	      (epg-user-id-name (car pointer))
+	      "\n")
       (setq pointer (cdr pointer)))
-    (insert "\nPublic keys:\n\n")
-    (setq pointer (epg-list-keys nil))
+    (setq pointer (epg-key-sub-key-list key))
     (while pointer
-      (setq point (point))
-      (setq entry (cdr (assq 'pub (car pointer))))
-      (setq key-id (cdr (assq 'key-id entry)))
-      (insert (format " %s %s %s\n"
-		      (or (cdr (assq 'trust entry)) ? )
-		      key-id
-		      (cdr (assq 'user-id (assq 'uid (car pointer))))))
-      (put-text-property point (point) 'epa-key-id key-id)
+      (insert " "
+	      (char-to-string
+	       (car (rassq (epg-sub-key-validity (car pointer))
+			   epg-key-validity-alist)))
+	      " "
+	      (epg-sub-key-id (car pointer))
+	      " "
+	      (format "%dbits"
+		      (epg-sub-key-length (car pointer)))
+	      " "
+	      (cdr (assq (epg-sub-key-algorithm (car pointer))
+			 epg-pubkey-algorithm-alist))
+	      "\n\tCreated: "
+	      (epg-sub-key-creation-time (car pointer))
+	      (if (epg-sub-key-expiration-time (car pointer))
+		  (format "\n\tExpires: %s" (epg-sub-key-expiration-time
+						  (car pointer)))
+		"")
+	      "\n\tCapabilities: "
+	      (mapconcat #'symbol-name
+			 (epg-sub-key-capability (car pointer))
+			 " ")
+	      "\n\tFingerprint: "
+	      (epg-sub-key-fingerprint (car pointer))
+	      "\n")
       (setq pointer (cdr pointer)))
     (goto-char (point-min))
     (pop-to-buffer (current-buffer))
-    (delete-other-windows)))
-
-(defun epa-key-id ()
-  (let ((key-id (get-text-property (point) 'epa-key-id))
-	point)
-    (unless key-id
-      (setq point (next-single-property-change (point) 'epa-key-id))
-      (when point
-	(goto-char point)
-	(setq key-id (get-text-property (point) 'epa-key-id))))
-    key-id))
-
-(defun epa-command-mark-key (key-id)
-  (interactive
-   (progn
-     (unless (eq major-mode 'epa-mode)
-       (error "Not in `epa-mode'"))
-     (list (epa-key-id))))
-  (let ((point (point))
-	(inhibit-read-only t)
-	buffer-read-only)
-    (while (and point
-		(not (equal (get-text-property point 'epa-key-id) key-id)))
-      (setq point (next-single-property-change point)))
-    (unless point
-      (error "Key %s not found" key-id))
-    (goto-char point)
+    (epa-key-mode)))
+
+(defun epa-show-key-notify (widget &rest ignore)
+  (epa-show-key (widget-value widget)))
+
+(defun epa-mark ()
+  "Mark the current line."
+  (interactive)
+  (let ((inhibit-read-only t)
+	buffer-read-only
+	properties)
     (beginning-of-line)
-    (delete-char)
-    (setq point (point))
+    (setq properties (text-properties-at (point)))
+    (delete-char 1)
     (insert "*")
-    (put-text-property point (point) 'epa-key-id key-id)
+    (set-text-properties (1- (point)) (point) properties)
     (forward-line)))
 
-(defun epa-command-unmark-key (key-id)
-  (interactive
-   (progn
-     (unless (eq major-mode 'epa-mode)
-       (error "Not in `epa-mode'"))
-     (list (epa-key-id))))
-  (let ((point (point))
-	(inhibit-read-only t)
-	buffer-read-only)
-    (while (and point
-		(not (equal (get-text-property point 'epa-key-id) key-id)))
-      (setq point (next-single-property-change point)))
-    (unless point
-      (error "Key %s not found" key-id))
-    (goto-char point)
+(defun epa-unmark ()
+  "Unmark the current line."
+  (interactive)
+  (let ((inhibit-read-only t)
+	buffer-read-only
+	properties)
     (beginning-of-line)
-    (delete-char)
-    (setq point (point))
+    (setq properties (text-properties-at (point)))
+    (delete-char 1)
     (insert " ")
-    (put-text-property point (point) 'epa-key-id key-id)
+    (set-text-properties (1- (point)) (point) properties)
     (forward-line)))
 
-(defun epa-command-next-line (count)
-  (interactive "p")
-  (if (get-text-property (point) 'epa-key-id)
-      (next-line count)
-    (let ((point (next-single-property-change (point) 'epa-key-id)))
-      (if (and point
-	       (get-text-property point 'epa-key-id))
-	  (goto-char point)))))
-
-(defun epa-command-encrypt-file (plain cipher recipients sign)
-  (interactive
-   (save-excursion
-     (set-buffer epa-buffer)
-     (goto-char (point-min))
-     (let (plain recipients)
-       (while (re-search-forward "^\\*" nil t)
-	 (unless (get-text-property (point) 'epa-key-secret)
-	   (setq recipients (cons (get-text-property (point) 'epa-key-id)
-				  recipients))))
-       (list (setq plain (expand-file-name (read-file-name "Plain file: ")))
-	     (expand-file-name
-	      (read-file-name (format "Cipher file (default %s.gpg) "
-				      (file-name-nondirectory plain))
-			      (file-name-directory plain)
-			      (concat plain ".gpg")))
-	     recipients
-	     current-prefix-arg))))
-  (message "Encrypting %s..." (file-name-nondirectory plain))
-  (epg-encrypt-file (epg-make-context)
-		    plain
-		    recipients
-		    (expand-file-name cipher)
-		    sign)
-  (message "Encrypting %s...done" (file-name-nondirectory plain)))
-
-(defun epa-command-sign-file (plain signature detached signers)
-  (interactive
-   (save-excursion
-     (set-buffer epa-buffer)
-     (goto-char (point-min))
-     (let ((extension (if current-prefix-arg ".sig" ".gpg"))
-	   plain signers)
-       (while (re-search-forward "^\\*" nil t)
-	 (if (get-text-property (point) 'epa-key-secret)
-	     (setq signers (cons (get-text-property (point) 'epa-key-id)
-				 signers))))
-       
-       (list (setq plain (expand-file-name (read-file-name "Plain file: ")))
-	     (expand-file-name
-	      (read-file-name (format "Signature file (default %s%s) "
-				      (file-name-nondirectory plain)
-				      extension)
-			      (file-name-directory plain)
-			      (concat plain extension)))
-	     current-prefix-arg
-	     signers))))
-  (let ((context (epg-make-context)))
-    (epg-context-set-signers context signers)
-    (message "Signing %s..." (file-name-nondirectory plain))
-    (epg-sign-file context
-		   plain
-		   signature
-		   (if detached 'detached))
-    (message "Signing %s...done" (file-name-nondirectory plain))))
-
 (provide 'epa)
 
 ;;; epa.el ends here