X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=epa.el;h=57dcb70d99c24dda9d7f0a33781e699885b5639f;hb=5bf1d8d87ad737fdc640a4c9024d56d7bb31a4ca;hp=45f1959868b76fa0eff818c6d91218b94a5aeb12;hpb=741cd9e39bc6f55ce7618672ae75b8b0a7654dd7;p=elisp%2Fepg.git diff --git a/epa.el b/epa.el index 45f1959..57dcb70 100644 --- a/epa.el +++ b/epa.el @@ -33,22 +33,6 @@ "The EasyPG Assistant" :group 'epg) -(defcustom epa-protocol 'OpenPGP - "The default protocol." - :type '(choice (const :tag "OpenPGP" OpenPGP) - (const :tag "CMS" CMS)) - :group 'epa) - -(defcustom epa-armor nil - "If non-nil, epa commands create ASCII armored output." - :type 'boolean - :group 'epa) - -(defcustom epa-textmode nil - "If non-nil, epa commands treat input files as text." - :type 'boolean - :group 'epa) - (defcustom epa-popup-info-window t "If non-nil, status information from epa commands is displayed on the separate window." @@ -64,98 +48,123 @@ the separate window." "Faces for epa-mode." :group 'epa) -(defface epa-validity-high-face - '((((class color) (background dark)) - (:foreground "PaleTurquoise" :bold t)) +(defface epa-validity-high + `((((class color) (background dark)) + (:foreground "PaleTurquoise" + ,@(if (assq ':weight custom-face-attributes) + '(:weight bold) + '(:bold t)))) (t - (:bold t))) + ,@(if (assq ':weight custom-face-attributes) + '(:weight bold) + '(:bold t)))) "Face used for displaying the high validity." :group 'epa-faces) -(defvar epa-validity-high-face 'epa-validity-high-face) -(defface epa-validity-medium-face - '((((class color) (background dark)) - (:foreground "PaleTurquoise" :italic t)) +(defface epa-validity-medium + `((((class color) (background dark)) + (:foreground "PaleTurquoise" + ,@(if (assq ':slant custom-face-attributes) + '(:slant italic) + '(:italic t)))) (t - ())) + (,@(if (assq ':slant custom-face-attributes) + '(:slant italic) + '(:italic t))))) "Face used for displaying the medium validity." :group 'epa-faces) -(defvar epa-validity-medium-face 'epa-validity-medium-face) -(defface epa-validity-low-face - '((t - (:italic t))) +(defface epa-validity-low + `((t + (,@(if (assq ':slant custom-face-attributes) + '(:slant italic) + '(:italic t))))) "Face used for displaying the low validity." :group 'epa-faces) -(defvar epa-validity-low-face 'epa-validity-low-face) -(defface epa-validity-disabled-face - '((t - (:italic t :inverse-video t))) +(defface epa-validity-disabled + `((t + (,@(if (assq ':slant custom-face-attributes) + '(:slant italic) + '(:italic t)) + :inverse-video t))) "Face used for displaying the disabled validity." :group 'epa-faces) -(defvar epa-validity-disabled-face 'epa-validity-disabled-face) -(defface epa-string-face - '((((class color) - (background dark)) +(defface epa-string + '((((class color) (background dark)) (:foreground "lightyellow")) - (((class color) - (background light)) - (:foreground "blue4")) - (t - ())) + (((class color) (background light)) + (:foreground "blue4"))) "Face used for displaying the string." :group 'epa-faces) -(defvar epa-string-face 'epa-string-face) -(defface epa-mark-face - '((((class color) (background dark)) - (:foreground "orange" :bold t)) +(defface epa-mark + `((((class color) (background dark)) + (:foreground "orange" + ,@(if (assq ':weight custom-face-attributes) + '(:weight bold) + '(:bold t)))) + (((class color) (background light)) + (:foreground "red" + ,@(if (assq ':weight custom-face-attributes) + '(:weight bold) + '(:bold t)))) (t - (:foreground "red" :bold t))) + (,@(if (assq ':weight custom-face-attributes) + '(:weight bold) + '(:bold t))))) "Face used for displaying the high validity." :group 'epa-faces) -(defvar epa-mark-face 'epa-mark-face) -(defface epa-field-name-face - '((((class color) (background dark)) - (:foreground "PaleTurquoise" :bold t)) - (t (:bold t))) +(defface epa-field-name + `((((class color) (background dark)) + (:foreground "PaleTurquoise" + ,@(if (assq ':weight custom-face-attributes) + '(:weight bold) + '(:bold t)))) + (t + (,@(if (assq ':weight custom-face-attributes) + '(:weight bold) + '(: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))) +(defface epa-field-body + `((((class color) (background dark)) + (:foreground "turquoise" + ,@(if (assq ':slant custom-face-attributes) + '(:slant italic) + '(:italic t)))) + (t + (,@(if (assq ':slant custom-face-attributes) + '(:slant italic) + '(: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 - '((unknown . epa-validity-disabled-face) - (invalid . epa-validity-disabled-face) - (disabled . epa-validity-disabled-face) - (revoked . epa-validity-disabled-face) - (expired . epa-validity-disabled-face) - (none . epa-validity-low-face) - (undefined . epa-validity-low-face) - (never . epa-validity-low-face) - (marginal . epa-validity-medium-face) - (full . epa-validity-high-face) - (ultimate . epa-validity-high-face)) + '((unknown . epa-validity-disabled) + (invalid . epa-validity-disabled) + (disabled . epa-validity-disabled) + (revoked . epa-validity-disabled) + (expired . epa-validity-disabled) + (none . epa-validity-low) + (undefined . epa-validity-low) + (never . epa-validity-low) + (marginal . epa-validity-medium) + (full . epa-validity-high) + (ultimate . epa-validity-high)) "An alist mapping validity values to faces." :type 'list :group 'epa) (defcustom epa-font-lock-keywords '(("^\\*" - (0 epa-mark-face)) + (0 'epa-mark)) ("^\t\\([^\t:]+:\\)[ \t]*\\(.*\\)$" - (1 epa-field-name-face) - (2 epa-field-body-face))) + (1 'epa-field-name) + (2 'epa-field-body))) "Default expressions to addon in epa-mode." :type '(repeat (list string)) :group 'epa) @@ -168,6 +177,22 @@ the separate window." (17 . ?D) (20 . ?G))) +(defvar epa-protocol 'OpenPGP + "*The default protocol. +The value can be either OpenPGP or CMS. + +You should bind this variable with `let', but do not set it globally.") + +(defvar epa-armor nil + "*If non-nil, epa commands create ASCII armored output. + +You should bind this variable with `let', but do not set it globally.") + +(defvar epa-textmode nil + "*If non-nil, epa commands treat input files as text. + +You should bind this variable with `let', but do not set it globally.") + (defvar epa-keys-buffer nil) (defvar epa-key-buffer-alist nil) (defvar epa-key nil) @@ -177,8 +202,8 @@ the separate window." (defvar epa-key-list-mode-map (let ((keymap (make-sparse-keymap))) - (define-key keymap "m" 'epa-mark) - (define-key keymap "u" 'epa-unmark) + (define-key keymap "m" 'epa-mark-key) + (define-key keymap "u" 'epa-unmark-key) (define-key keymap "d" 'epa-decrypt-file) (define-key keymap "v" 'epa-verify-file) (define-key keymap "s" 'epa-sign-file) @@ -186,6 +211,7 @@ the separate window." (define-key keymap "r" 'epa-delete-keys) (define-key keymap "i" 'epa-import-keys) (define-key keymap "o" 'epa-export-keys) + (define-key keymap "g" 'revert-buffer) (define-key keymap "n" 'next-line) (define-key keymap "p" 'previous-line) (define-key keymap " " 'scroll-up) @@ -195,7 +221,7 @@ the separate window." (defvar epa-key-mode-map (let ((keymap (make-sparse-keymap))) - (define-key keymap "q" 'bury-buffer) + (define-key keymap "q" 'epa-exit-buffer) keymap)) (defvar epa-info-mode-map @@ -245,13 +271,15 @@ the separate window." (epg-sub-key-id (car (epg-key-sub-key-list (widget-get widget :value)))))) -(if (fboundp 'encode-coding-string) - (defalias 'epa--encode-coding-string 'encode-coding-string) - (defalias 'epa--encode-coding-string 'identity)) +(eval-and-compile + (if (fboundp 'encode-coding-string) + (defalias 'epa--encode-coding-string 'encode-coding-string) + (defalias 'epa--encode-coding-string 'identity))) -(if (fboundp 'decode-coding-string) - (defalias 'epa--decode-coding-string 'decode-coding-string) - (defalias 'epa--decode-coding-string 'identity)) +(eval-and-compile + (if (fboundp 'decode-coding-string) + (defalias 'epa--decode-coding-string 'decode-coding-string) + (defalias 'epa--decode-coding-string 'identity))) (defun epa-key-list-mode () "Major mode for `epa-list-keys'." @@ -268,6 +296,8 @@ the separate window." ;; if buffer-file-name is not set. (font-lock-set-defaults) (make-local-variable 'epa-exit-buffer-function) + (make-local-variable 'revert-buffer-function) + (setq revert-buffer-function 'epa--key-list-revert-buffer) (run-hooks 'epa-key-list-mode-hook)) (defun epa-key-mode () @@ -298,30 +328,27 @@ the separate window." (use-local-map epa-info-mode-map) (run-hooks 'epa-info-mode-hook)) -(defun epa-mark (&optional arg) - "Mark the current line. -If ARG is non-nil, unmark the current line." +(defun epa-mark-key (&optional arg) + "Mark a key on the current line. +If ARG is non-nil, unmark the key." (interactive "P") (let ((inhibit-read-only t) buffer-read-only properties) (beginning-of-line) + (unless (get-text-property (point) 'epa-key) + (error "No key on this line")) (setq properties (text-properties-at (point))) (delete-char 1) (insert (if arg " " "*")) (set-text-properties (1- (point)) (point) properties) (forward-line))) -(defun epa-unmark (&optional arg) - "Unmark the current line. -If ARG is non-nil, mark the current line." +(defun epa-unmark-key (&optional arg) + "Unmark a key on the current line. +If ARG is non-nil, mark the key." (interactive "P") - (epa-mark (not arg))) - -(defun epa-toggle-mark () - "Toggle the mark the current line." - (interactive) - (epa-mark (eq (char-after (save-excursion (beginning-of-line) (point))) ?*))) + (epa-mark-key (not arg))) (defun epa-exit-buffer () "Exit the current buffer. @@ -329,12 +356,11 @@ If ARG is non-nil, mark the current line." (interactive) (funcall epa-exit-buffer-function)) -(defun epa--insert-keys (context name mode) +(defun epa--insert-keys (keys) (save-excursion (save-restriction (narrow-to-region (point) (point)) - (let ((keys (epg-list-keys context name mode)) - point) + (let (point) (while keys (setq point (point)) (insert " ") @@ -371,7 +397,7 @@ If ARG is non-nil, mark the current line." (or (next-single-property-change point 'epa-list-keys) (point-max))) (goto-char point)) - (epa--insert-keys context name secret) + (epa--insert-keys (epg-list-keys context name secret)) (widget-setup) (set-keymap-parent (current-local-map) widget-keymap)) (make-local-variable 'epa-list-keys-arguments) @@ -403,6 +429,9 @@ If ARG is non-nil, mark the current line." (list nil))) (epa--list-keys name t)) +(defun epa--key-list-revert-buffer (&optional ignore-auto noconfirm) + (apply #'epa--list-keys epa-list-keys-arguments)) + (defun epa--marked-keys () (or (save-excursion (set-buffer epa-keys-buffer) @@ -419,14 +448,7 @@ If ARG is non-nil, mark the current line." (if key (list key)))))) -;;;###autoload -(defun epa-select-keys (context prompt &optional names secret) - "Display a user's keyring and ask him to select keys. -CONTEXT is an epg-context. -PROMPT is a string to prompt with. -NAMES is a list of strings to be matched with keys. If it is nil, all -the keys are listed. -If SECRET is non-nil, list secret keys instead of public keys." +(defun epa--select-keys (prompt keys) (save-excursion (unless (and epa-keys-buffer (buffer-live-p epa-keys-buffer)) @@ -438,8 +460,8 @@ If SECRET is non-nil, list secret keys instead of public keys." (erase-buffer) (insert prompt "\n" (substitute-command-keys "\ -- `\\[epa-mark]' to mark a key on the line -- `\\[epa-unmark]' to unmark a key on the line\n")) +- `\\[epa-mark-key]' to mark a key on the line +- `\\[epa-unmark-key]' to unmark a key on the line\n")) (widget-create 'link :notify (lambda (&rest ignore) (abort-recursive-edit)) :help-echo @@ -453,7 +475,7 @@ If SECRET is non-nil, list secret keys instead of public keys." "Click here or \\[exit-recursive-edit] to finish") "OK") (insert "\n\n") - (epa--insert-keys context names secret) + (epa--insert-keys keys) (widget-setup) (set-keymap-parent (current-local-map) widget-keymap) (setq epa-exit-buffer-function #'abort-recursive-edit) @@ -467,6 +489,19 @@ If SECRET is non-nil, list secret keys instead of public keys." (delete-window (get-buffer-window epa-keys-buffer))) (kill-buffer epa-keys-buffer)))) +;;;###autoload +(defun epa-select-keys (context prompt &optional names secret) + "Display a user's keyring and ask him to select keys. +CONTEXT is an epg-context. +PROMPT is a string to prompt with. +NAMES is a list of strings to be matched with keys. If it is nil, all +the keys are listed. +If SECRET is non-nil, list secret keys instead of public keys." + (let ((keys (epg-list-keys context names secret))) + (if (> (length keys) 1) + (epa--select-keys prompt keys) + keys))) + (defun epa--format-fingerprint-1 (fingerprint unit-size block-size) (let ((unit 0)) (with-temp-buffer @@ -869,10 +904,11 @@ Don't use this command in Lisp programs!" (error "No cleartext tail")) (epa-verify-region cleartext-start cleartext-end)))))) -(if (fboundp 'select-safe-coding-system) - (defalias 'epa--select-safe-coding-system 'select-safe-coding-system) - (defun epa--select-safe-coding-system (from to) - buffer-file-coding-system)) +(eval-and-compile + (if (fboundp 'select-safe-coding-system) + (defalias 'epa--select-safe-coding-system 'select-safe-coding-system) + (defun epa--select-safe-coding-system (from to) + buffer-file-coding-system))) ;;;###autoload (defun epa-sign-region (start end signers mode) @@ -930,15 +966,16 @@ If no one is selected, default secret key is used. " 'start-open t 'end-open t))))) -(if (fboundp 'derived-mode-p) - (defalias 'epa--derived-mode-p 'derived-mode-p) - (defun epa--derived-mode-p (&rest modes) - "Non-nil if the current major mode is derived from one of MODES. +(eval-and-compile + (if (fboundp 'derived-mode-p) + (defalias 'epa--derived-mode-p 'derived-mode-p) + (defun epa--derived-mode-p (&rest modes) + "Non-nil if the current major mode is derived from one of MODES. Uses the `derived-mode-parent' property of the symbol to trace backwards." - (let ((parent major-mode)) - (while (and (not (memq parent modes)) - (setq parent (get parent 'derived-mode-parent)))) - parent))) + (let ((parent major-mode)) + (while (and (not (memq parent modes)) + (setq parent (get parent 'derived-mode-parent)))) + parent)))) ;;;###autoload (defun epa-encrypt-region (start end recipients sign signers)