epa.el

   1 ;;; epa.el --- the EasyPG Assistant
   2 ;; Copyright (C) 2006 Daiki Ueno
   3
   4 ;; Author: Daiki Ueno <ueno@unixuser.org>
   5 ;; Keywords: PGP, GnuPG
   6
   7 ;; This file is part of EasyPG.
   8
   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)
  12 ;; any later version.
  13
  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.
  18
  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.
  23
  24 ;;; Code:
  25
  26 (require 'epg)
  27 (require 'font-lock)
  28 (require 'widget)
  29 (eval-when-compile (require 'wid-edit))
  30 (require 'derived)
  31
  32 (defgroup epa nil
  33   "The EasyPG Assistant"
  34   :group 'epg)
  35
  36 (defcustom epa-popup-info-window t
  37   "If non-nil, status information from epa commands is displayed on
  38 the separate window."
  39   :type 'boolean
  40   :group 'epa)
  41
  42 (defcustom epa-info-window-height 5
  43   "Number of lines used to display status information."
  44   :type 'integer
  45   :group 'epa)
  46
  47 (defgroup epa-faces nil
  48   "Faces for epa-mode."
  49   :group 'epa)
  50
  51 (defface epa-validity-high-face
  52   '((((class color) (background dark))
  53      (:foreground "PaleTurquoise" :bold t))
  54     (t
  55      (:bold t)))
  56   "Face used for displaying the high validity."
  57   :group 'epa-faces)
  58 (defvar epa-validity-high-face 'epa-validity-high-face)
  59
  60 (defface epa-validity-medium-face
  61   '((((class color) (background dark))
  62      (:foreground "PaleTurquoise" :italic t))
  63     (t
  64      ()))
  65   "Face used for displaying the medium validity."
  66   :group 'epa-faces)
  67 (defvar epa-validity-medium-face 'epa-validity-medium-face)
  68
  69 (defface epa-validity-low-face
  70   '((t
  71      (:italic t)))
  72   "Face used for displaying the low validity."
  73   :group 'epa-faces)
  74 (defvar epa-validity-low-face 'epa-validity-low-face)
  75
  76 (defface epa-validity-disabled-face
  77   '((t
  78      (:italic t :inverse-video t)))
  79   "Face used for displaying the disabled validity."
  80   :group 'epa-faces)
  81 (defvar epa-validity-disabled-face 'epa-validity-disabled-face)
  82
  83 (defface epa-string-face
  84   '((((class color)
  85       (background dark))
  86      (:foreground "lightyellow"))
  87     (((class color)
  88       (background light))
  89      (:foreground "blue4"))
  90     (t
  91      ()))
  92   "Face used for displaying the string."
  93   :group 'epa-faces)
  94 (defvar epa-string-face 'epa-string-face)
  95
  96 (defface epa-mark-face
  97   '((((class color) (background dark))
  98      (:foreground "orange" :bold t))
  99     (t
 100      (:foreground "red" :bold t)))
 101   "Face used for displaying the high validity."
 102   :group 'epa-faces)
 103 (defvar epa-mark-face 'epa-mark-face)
 104
 105 (defface epa-field-name-face
 106   '((((class color) (background dark))
 107      (:foreground "PaleTurquoise" :bold t))
 108     (t (:bold t)))
 109   "Face for the name of the attribute field."
 110   :group 'epa)
 111 (defvar epa-field-name-face 'epa-field-name-face)
 112
 113 (defface epa-field-body-face
 114   '((((class color) (background dark))
 115      (:foreground "turquoise" :italic t))
 116     (t (:italic t)))
 117   "Face for the body of the attribute field."
 118   :group 'epa)
 119 (defvar epa-field-body-face 'epa-field-body-face)
 120
 121 (defcustom epa-validity-face-alist
 122   '((unknown . epa-validity-disabled-face)
 123     (invalid . epa-validity-disabled-face)
 124     (disabled . epa-validity-disabled-face)
 125     (revoked . epa-validity-disabled-face)
 126     (expired . epa-validity-disabled-face)
 127     (none . epa-validity-low-face)
 128     (undefined . epa-validity-low-face)
 129     (never . epa-validity-low-face)
 130     (marginal . epa-validity-medium-face)
 131     (full . epa-validity-high-face)
 132     (ultimate . epa-validity-high-face))
 133   "An alist mapping validity values to faces."
 134   :type 'list
 135   :group 'epa)
 136
 137 (defcustom epa-font-lock-keywords
 138   '(("^\\*"
 139      (0 epa-mark-face))
 140     ("^\t\\([^\t:]+:\\)[ \t]*\\(.*\\)$"
 141      (1 epa-field-name-face)
 142      (2 epa-field-body-face)))
 143   "Default expressions to addon in epa-mode."
 144   :type '(repeat (list string))
 145   :group 'epa)
 146
 147 (defconst epa-pubkey-algorithm-letter-alist
 148   '((1 . ?R)
 149     (2 . ?r)
 150     (3 . ?s)
 151     (16 . ?g)
 152     (17 . ?D)
 153     (20 . ?G)))
 154
 155 (defvar epa-protocol 'OpenPGP
 156   "*The default protocol.
 157 The value can be either OpenPGP or CMS.
 158
 159 You should bind this variable with `let', but do not set it globally.")
 160
 161 (defvar epa-armor nil
 162   "*If non-nil, epa commands create ASCII armored output.
 163
 164 You should bind this variable with `let', but do not set it globally.")
 165
 166 (defvar epa-textmode nil
 167   "*If non-nil, epa commands treat input files as text.
 168
 169 You should bind this variable with `let', but do not set it globally.")
 170
 171 (defvar epa-keys-buffer nil)
 172 (defvar epa-key-buffer-alist nil)
 173 (defvar epa-key nil)
 174 (defvar epa-list-keys-arguments nil)
 175 (defvar epa-info-buffer nil)
 176 (defvar epa-last-coding-system-specified nil)
 177
 178 (defvar epa-key-list-mode-map
 179   (let ((keymap (make-sparse-keymap)))
 180     (define-key keymap "m" 'epa-mark-key)
 181     (define-key keymap "u" 'epa-unmark-key)
 182     (define-key keymap "d" 'epa-decrypt-file)
 183     (define-key keymap "v" 'epa-verify-file)
 184     (define-key keymap "s" 'epa-sign-file)
 185     (define-key keymap "e" 'epa-encrypt-file)
 186     (define-key keymap "r" 'epa-delete-keys)
 187     (define-key keymap "i" 'epa-import-keys)
 188     (define-key keymap "o" 'epa-export-keys)
 189     (define-key keymap "g" 'revert-buffer)
 190     (define-key keymap "n" 'next-line)
 191     (define-key keymap "p" 'previous-line)
 192     (define-key keymap " " 'scroll-up)
 193     (define-key keymap [delete] 'scroll-down)
 194     (define-key keymap "q" 'epa-exit-buffer)
 195     keymap))
 196
 197 (defvar epa-key-mode-map
 198   (let ((keymap (make-sparse-keymap)))
 199     (define-key keymap "q" 'epa-exit-buffer)
 200     keymap))
 201
 202 (defvar epa-info-mode-map
 203   (let ((keymap (make-sparse-keymap)))
 204     (define-key keymap "q" 'delete-window)
 205     keymap))
 206
 207 (defvar epa-exit-buffer-function #'bury-buffer)
 208
 209 (define-widget 'epa-key 'push-button
 210   "Button for representing a epg-key object."
 211   :format "%[%v%]"
 212   :button-face-get 'epa--key-widget-button-face-get
 213   :value-create 'epa--key-widget-value-create
 214   :action 'epa--key-widget-action
 215   :help-echo 'epa--key-widget-help-echo)
 216
 217 (defun epa--key-widget-action (widget &optional event)
 218   (epa--show-key (widget-get widget :value)))
 219
 220 (defun epa--key-widget-value-create (widget)
 221   (let* ((key (widget-get widget :value))
 222          (primary-sub-key (car (epg-key-sub-key-list key)))
 223          (primary-user-id (car (epg-key-user-id-list key))))
 224     (insert (format "%c "
 225                     (if (epg-sub-key-validity primary-sub-key)
 226                         (car (rassq (epg-sub-key-validity primary-sub-key)
 227                                     epg-key-validity-alist))
 228                       ? ))
 229             (epg-sub-key-id primary-sub-key)
 230             " "
 231             (if primary-user-id
 232                 (if (stringp (epg-user-id-string primary-user-id))
 233                     (epg-user-id-string primary-user-id)
 234                   (epg-decode-dn (epg-user-id-string primary-user-id)))
 235               ""))))
 236
 237 (defun epa--key-widget-button-face-get (widget)
 238   (let ((validity (epg-sub-key-validity (car (epg-key-sub-key-list
 239                                               (widget-get widget :value))))))
 240     (if validity
 241         (cdr (assq validity epa-validity-face-alist))
 242       'default)))
 243
 244 (defun epa--key-widget-help-echo (widget)
 245   (format "Show %s"
 246           (epg-sub-key-id (car (epg-key-sub-key-list
 247                                 (widget-get widget :value))))))
 248
 249 (if (fboundp 'encode-coding-string)
 250     (defalias 'epa--encode-coding-string 'encode-coding-string)
 251   (defalias 'epa--encode-coding-string 'identity))
 252
 253 (if (fboundp 'decode-coding-string)
 254     (defalias 'epa--decode-coding-string 'decode-coding-string)
 255   (defalias 'epa--decode-coding-string 'identity))
 256
 257 (defun epa-key-list-mode ()
 258   "Major mode for `epa-list-keys'."
 259   (kill-all-local-variables)
 260   (buffer-disable-undo)
 261   (setq major-mode 'epa-key-list-mode
 262         mode-name "Keys"
 263         truncate-lines t
 264         buffer-read-only t)
 265   (use-local-map epa-key-list-mode-map)
 266   (make-local-variable 'font-lock-defaults)
 267   (setq font-lock-defaults '(epa-font-lock-keywords t))
 268   ;; In XEmacs, auto-initialization of font-lock is not effective
 269   ;; if buffer-file-name is not set.
 270   (font-lock-set-defaults)
 271   (make-local-variable 'epa-exit-buffer-function)
 272   (make-local-variable 'revert-buffer-function)
 273   (setq revert-buffer-function 'epa--key-list-revert-buffer)
 274   (run-hooks 'epa-key-list-mode-hook))
 275
 276 (defun epa-key-mode ()
 277   "Major mode for a key description."
 278   (kill-all-local-variables)
 279   (buffer-disable-undo)
 280   (setq major-mode 'epa-key-mode
 281         mode-name "Key"
 282         truncate-lines t
 283         buffer-read-only t)
 284   (use-local-map epa-key-mode-map)
 285   (make-local-variable 'font-lock-defaults)
 286   (setq font-lock-defaults '(epa-font-lock-keywords t))
 287   ;; In XEmacs, auto-initialization of font-lock is not effective
 288   ;; if buffer-file-name is not set.
 289   (font-lock-set-defaults)
 290   (make-local-variable 'epa-exit-buffer-function)
 291   (run-hooks 'epa-key-mode-hook))
 292
 293 (defun epa-info-mode ()
 294   "Major mode for `epa-info-buffer'."
 295   (kill-all-local-variables)
 296   (buffer-disable-undo)
 297   (setq major-mode 'epa-info-mode
 298         mode-name "Info"
 299         truncate-lines t
 300         buffer-read-only t)
 301   (use-local-map epa-info-mode-map)
 302   (run-hooks 'epa-info-mode-hook))
 303
 304 (defun epa-mark-key (&optional arg)
 305   "Mark a key on the current line.
 306 If ARG is non-nil, unmark the key."
 307   (interactive "P")
 308   (let ((inhibit-read-only t)
 309         buffer-read-only
 310         properties)
 311     (beginning-of-line)
 312     (unless (get-text-property (point) 'epa-key)
 313       (error "No key on this line"))
 314     (setq properties (text-properties-at (point)))
 315     (delete-char 1)
 316     (insert (if arg " " "*"))
 317     (set-text-properties (1- (point)) (point) properties)
 318     (forward-line)))
 319
 320 (defun epa-unmark-key (&optional arg)
 321   "Unmark a key on the current line.
 322 If ARG is non-nil, mark the key."
 323   (interactive "P")
 324   (epa-mark-key (not arg)))
 325
 326 (defun epa-exit-buffer ()
 327   "Exit the current buffer.
 328 `epa-exit-buffer-function' is called if it is set."
 329   (interactive)
 330   (funcall epa-exit-buffer-function))
 331
 332 (defun epa--insert-keys (keys)
 333   (save-excursion
 334     (save-restriction
 335       (narrow-to-region (point) (point))
 336       (let (point)
 337         (while keys
 338           (setq point (point))
 339           (insert "  ")
 340           (add-text-properties point (point)
 341                                (list 'epa-key (car keys)
 342                                      'front-sticky nil
 343                                      'rear-nonsticky t
 344                                      'start-open t
 345                                      'end-open t))
 346           (widget-create 'epa-key :value (car keys))
 347           (insert "\n")
 348           (setq keys (cdr keys))))
 349       (add-text-properties (point-min) (point-max)
 350                            (list 'epa-list-keys t
 351                                  'front-sticky nil
 352                                  'rear-nonsticky t
 353                                  'start-open t
 354                                  'end-open t)))))
 355
 356 (defun epa--list-keys (name secret)
 357   (unless (and epa-keys-buffer
 358                (buffer-live-p epa-keys-buffer))
 359     (setq epa-keys-buffer (generate-new-buffer "*Keys*")))
 360   (set-buffer epa-keys-buffer)
 361   (epa-key-list-mode)
 362   (let ((inhibit-read-only t)
 363         buffer-read-only
 364         (point (point-min))
 365         (context (epg-make-context epa-protocol)))
 366     (unless (get-text-property point 'epa-list-keys)
 367       (setq point (next-single-property-change point 'epa-list-keys)))
 368     (when point
 369       (delete-region point
 370                      (or (next-single-property-change point 'epa-list-keys)
 371                          (point-max)))
 372       (goto-char point))
 373     (epa--insert-keys (epg-list-keys context name secret))
 374     (widget-setup)
 375     (set-keymap-parent (current-local-map) widget-keymap))
 376   (make-local-variable 'epa-list-keys-arguments)
 377   (setq epa-list-keys-arguments (list name secret))
 378   (goto-char (point-min))
 379   (pop-to-buffer (current-buffer)))
 380
 381 ;;;###autoload
 382 (defun epa-list-keys (&optional name)
 383   "List all keys matched with NAME from the public keyring."
 384   (interactive
 385    (if current-prefix-arg
 386        (let ((name (read-string "Pattern: "
 387                                 (if epa-list-keys-arguments
 388                                     (car epa-list-keys-arguments)))))
 389          (list (if (equal name "") nil name)))
 390      (list nil)))
 391   (epa--list-keys name nil))
 392
 393 ;;;###autoload
 394 (defun epa-list-secret-keys (&optional name)
 395   "List all keys matched with NAME from the private keyring."
 396   (interactive
 397    (if current-prefix-arg
 398        (let ((name (read-string "Pattern: "
 399                                 (if epa-list-keys-arguments
 400                                     (car epa-list-keys-arguments)))))
 401          (list (if (equal name "") nil name)))
 402      (list nil)))
 403   (epa--list-keys name t))
 404
 405 (defun epa--key-list-revert-buffer (&optional ignore-auto noconfirm)
 406   (apply #'epa--list-keys epa-list-keys-arguments))
 407
 408 (defun epa--marked-keys ()
 409   (or (save-excursion
 410         (set-buffer epa-keys-buffer)
 411         (goto-char (point-min))
 412         (let (keys key)
 413           (while (re-search-forward "^\\*" nil t)
 414             (if (setq key (get-text-property (match-beginning 0)
 415                                              'epa-key))
 416                 (setq keys (cons key keys))))
 417           (nreverse keys)))
 418       (save-excursion
 419         (beginning-of-line)
 420         (let ((key (get-text-property (point) 'epa-key)))
 421           (if key
 422               (list key))))))
 423
 424 (defun epa--select-keys (prompt keys)
 425   (save-excursion
 426     (unless (and epa-keys-buffer
 427                  (buffer-live-p epa-keys-buffer))
 428       (setq epa-keys-buffer (generate-new-buffer "*Keys*")))
 429     (set-buffer epa-keys-buffer)
 430     (epa-key-list-mode)
 431     (let ((inhibit-read-only t)
 432           buffer-read-only)
 433       (erase-buffer)
 434       (insert prompt "\n"
 435               (substitute-command-keys "\
 436 - `\\[epa-mark-key]' to mark a key on the line
 437 - `\\[epa-unmark-key]' to unmark a key on the line\n"))
 438       (widget-create 'link
 439                      :notify (lambda (&rest ignore) (abort-recursive-edit))
 440                      :help-echo
 441                      (substitute-command-keys
 442                       "Click here or \\[abort-recursive-edit] to cancel")
 443                      "Cancel")
 444       (widget-create 'link
 445                      :notify (lambda (&rest ignore) (exit-recursive-edit))
 446                      :help-echo
 447                      (substitute-command-keys
 448                       "Click here or \\[exit-recursive-edit] to finish")
 449                      "OK")
 450       (insert "\n\n")
 451       (epa--insert-keys keys)
 452       (widget-setup)
 453       (set-keymap-parent (current-local-map) widget-keymap)
 454       (setq epa-exit-buffer-function #'abort-recursive-edit)
 455       (goto-char (point-min))
 456       (pop-to-buffer (current-buffer)))
 457     (unwind-protect
 458         (progn
 459           (recursive-edit)
 460           (epa--marked-keys))
 461       (if (get-buffer-window epa-keys-buffer)
 462           (delete-window (get-buffer-window epa-keys-buffer)))
 463       (kill-buffer epa-keys-buffer))))
 464
 465 ;;;###autoload
 466 (defun epa-select-keys (context prompt &optional names secret)
 467   "Display a user's keyring and ask him to select keys.
 468 CONTEXT is an epg-context.
 469 PROMPT is a string to prompt with.
 470 NAMES is a list of strings to be matched with keys.  If it is nil, all
 471 the keys are listed.
 472 If SECRET is non-nil, list secret keys instead of public keys."
 473   (let ((keys (epg-list-keys context names secret)))
 474     (if (> (length keys) 1)
 475         (epa--select-keys prompt keys)
 476       keys)))
 477
 478 (defun epa--format-fingerprint-1 (fingerprint unit-size block-size)
 479   (let ((unit 0))
 480     (with-temp-buffer
 481       (insert fingerprint)
 482       (goto-char (point-min))
 483       (while (progn
 484                (goto-char (+ (point) unit-size))
 485                (not (eobp)))
 486         (setq unit (1+ unit))
 487         (insert (if (= (% unit block-size) 0) "  " " ")))
 488       (buffer-string))))
 489
 490 (defun epa--format-fingerprint (fingerprint)
 491   (if fingerprint
 492       (if (= (length fingerprint) 40)
 493           ;; 1234 5678 9ABC DEF0 1234  5678 9ABC DEF0 1234 5678
 494           (epa--format-fingerprint-1 fingerprint 4 5)
 495         ;; 12 34 56 78 9A BC DE F0  12 34 56 78 9A BC DE F0
 496         (epa--format-fingerprint-1 fingerprint 2 8))))
 497
 498 (defun epa--show-key (key)
 499   (let* ((primary-sub-key (car (epg-key-sub-key-list key)))
 500          (entry (assoc (epg-sub-key-id primary-sub-key)
 501                        epa-key-buffer-alist))
 502          (inhibit-read-only t)
 503          buffer-read-only
 504          pointer)
 505     (unless entry
 506       (setq entry (cons (epg-sub-key-id primary-sub-key) nil)
 507             epa-key-buffer-alist (cons entry epa-key-buffer-alist)))
 508     (unless (and (cdr entry)
 509                  (buffer-live-p (cdr entry)))
 510       (setcdr entry (generate-new-buffer
 511                      (format "*Key*%s" (epg-sub-key-id primary-sub-key)))))
 512     (set-buffer (cdr entry))
 513     (epa-key-mode)
 514     (make-local-variable 'epa-key)
 515     (setq epa-key key)
 516     (erase-buffer)
 517     (setq pointer (epg-key-user-id-list key))
 518     (while pointer
 519       (if (car pointer)
 520           (insert " "
 521                   (if (epg-user-id-validity (car pointer))
 522                       (char-to-string
 523                        (car (rassq (epg-user-id-validity (car pointer))
 524                                    epg-key-validity-alist)))
 525                     " ")
 526                   " "
 527                   (if (stringp (epg-user-id-string (car pointer)))
 528                       (epg-user-id-string (car pointer))
 529                     (epg-decode-dn (epg-user-id-string (car pointer))))
 530                   "\n"))
 531       (setq pointer (cdr pointer)))
 532     (setq pointer (epg-key-sub-key-list key))
 533     (while pointer
 534       (insert " "
 535               (if (epg-sub-key-validity (car pointer))
 536                   (char-to-string
 537                    (car (rassq (epg-sub-key-validity (car pointer))
 538                                epg-key-validity-alist)))
 539                 " ")
 540               " "
 541               (epg-sub-key-id (car pointer))
 542               " "
 543               (format "%dbits"
 544                       (epg-sub-key-length (car pointer)))
 545               " "
 546               (cdr (assq (epg-sub-key-algorithm (car pointer))
 547                          epg-pubkey-algorithm-alist))
 548               "\n\tCreated: "
 549               (format-time-string "%Y-%m-%d"
 550                                   (epg-sub-key-creation-time (car pointer)))
 551               (if (epg-sub-key-expiration-time (car pointer))
 552                   (format "\n\tExpires: %s"
 553                           (format-time-string "%Y-%m-%d"
 554                                               (epg-sub-key-expiration-time
 555                                                (car pointer))))
 556                 "")
 557               "\n\tCapabilities: "
 558               (mapconcat #'symbol-name
 559                          (epg-sub-key-capability (car pointer))
 560                          " ")
 561               "\n\tFingerprint: "
 562               (epa--format-fingerprint (epg-sub-key-fingerprint (car pointer)))
 563               "\n")
 564       (setq pointer (cdr pointer)))
 565     (goto-char (point-min))
 566     (pop-to-buffer (current-buffer))))
 567
 568 (defun epa-display-info (info)
 569   (if epa-popup-info-window
 570       (save-selected-window
 571         (unless (and epa-info-buffer (buffer-live-p epa-info-buffer))
 572           (setq epa-info-buffer (generate-new-buffer "*Info*")))
 573         (if (get-buffer-window epa-info-buffer)
 574             (delete-window (get-buffer-window epa-info-buffer)))
 575         (save-excursion
 576           (set-buffer epa-info-buffer)
 577           (let ((inhibit-read-only t)
 578                 buffer-read-only)
 579             (erase-buffer)
 580             (insert info))
 581           (epa-info-mode)
 582           (goto-char (point-min)))
 583         (if (> (window-height)
 584                epa-info-window-height)
 585             (set-window-buffer (split-window nil (- (window-height)
 586                                                     epa-info-window-height))
 587                                epa-info-buffer)
 588           (pop-to-buffer epa-info-buffer)
 589           (if (> (window-height) epa-info-window-height)
 590               (shrink-window (- (window-height) epa-info-window-height)))))
 591     (message "%s" info)))
 592
 593 (defun epa-display-verify-result (verify-result)
 594   (epa-display-info (epg-verify-result-to-string verify-result)))
 595 (make-obsolete 'epa-display-verify-result 'epa-display-info)
 596
 597 (defun epa-passphrase-callback-function (context key-id handback)
 598   (if (eq key-id 'SYM)
 599       (read-passwd "Passphrase for symmetric encryption: "
 600                    (eq (epg-context-operation context) 'encrypt))
 601     (read-passwd
 602      (if (eq key-id 'PIN)
 603         "Passphrase for PIN: "
 604        (let ((entry (assoc key-id epg-user-id-alist)))
 605          (if entry
 606              (format "Passphrase for %s %s: " key-id (cdr entry))
 607            (format "Passphrase for %s: " key-id)))))))
 608
 609 (defun epa-progress-callback-function (context what char current total
 610                                                handback)
 611   (message "%s%d%% (%d/%d)" (or handback
 612                                 (concat what ": "))
 613            (if (> total 0) (floor (* (/ current (float total)) 100)) 0)
 614            current total))
 615
 616 ;;;###autoload
 617 (defun epa-decrypt-file (file)
 618   "Decrypt FILE."
 619   (interactive "fFile: ")
 620   (setq file (expand-file-name file))
 621   (let* ((default-name (file-name-sans-extension file))
 622          (plain (expand-file-name
 623                  (read-file-name
 624                   (concat "To file (default "
 625                           (file-name-nondirectory default-name)
 626                           ") ")
 627                   (file-name-directory default-name)
 628                   default-name)))
 629          (context (epg-make-context epa-protocol)))
 630     (epg-context-set-passphrase-callback context
 631                                          #'epa-passphrase-callback-function)
 632     (epg-context-set-progress-callback context
 633                                        #'epa-progress-callback-function
 634                                        (format "Decrypting %s..."
 635                                                (file-name-nondirectory file)))
 636     (message "Decrypting %s..." (file-name-nondirectory file))
 637     (epg-decrypt-file context file plain)
 638     (message "Decrypting %s...wrote %s" (file-name-nondirectory file)
 639              (file-name-nondirectory plain))
 640     (if (epg-context-result-for context 'verify)
 641         (epa-display-info (epg-verify-result-to-string
 642                            (epg-context-result-for context 'verify))))))
 643
 644 ;;;###autoload
 645 (defun epa-verify-file (file)
 646   "Verify FILE."
 647   (interactive "fFile: ")
 648   (setq file (expand-file-name file))
 649   (let* ((context (epg-make-context epa-protocol))
 650          (plain (if (equal (file-name-extension file) "sig")
 651                     (file-name-sans-extension file))))
 652     (epg-context-set-progress-callback context
 653                                        #'epa-progress-callback-function
 654                                        (format "Verifying %s..."
 655                                                (file-name-nondirectory file)))
 656     (message "Verifying %s..." (file-name-nondirectory file))
 657     (epg-verify-file context file plain)
 658     (message "Verifying %s...done" (file-name-nondirectory file))
 659     (if (epg-context-result-for context 'verify)
 660         (epa-display-info (epg-verify-result-to-string
 661                            (epg-context-result-for context 'verify))))))
 662
 663 (defun epa--read-signature-type ()
 664   (let (type c)
 665     (while (null type)
 666       (message "Signature type (n,c,d,?) ")
 667       (setq c (read-char))
 668       (cond ((eq c ?c)
 669              (setq type 'clear))
 670             ((eq c ?d)
 671              (setq type 'detached))
 672             ((eq c ??)
 673              (with-output-to-temp-buffer "*Help*"
 674                (save-excursion
 675                  (set-buffer standard-output)
 676                  (insert "\
 677 n - Create a normal signature
 678 c - Create a cleartext signature
 679 d - Create a detached signature
 680 ? - Show this help
 681 "))))
 682             (t
 683              (setq type 'normal))))))
 684
 685 ;;;###autoload
 686 (defun epa-sign-file (file signers mode)
 687   "Sign FILE by SIGNERS keys selected."
 688   (interactive
 689    (let ((verbose current-prefix-arg))
 690      (list (expand-file-name (read-file-name "File: "))
 691            (if verbose
 692                (epa-select-keys (epg-make-context epa-protocol)
 693                                 "Select keys for signing.
 694 If no one is selected, default secret key is used.  "
 695                                 nil t))
 696            (if verbose
 697                (epa--read-signature-type)
 698              'clear))))
 699   (let ((signature (concat file
 700                            (if (eq epa-protocol 'OpenPGP)
 701                                (if (or epa-armor
 702                                        (not (memq mode
 703                                                   '(nil t normal detached))))
 704                                    ".asc"
 705                                  (if (memq mode '(t detached))
 706                                      ".sig"
 707                                    ".gpg"))
 708                              (if (memq mode '(t detached))
 709                                  ".p7s"
 710                                ".p7m"))))
 711         (context (epg-make-context epa-protocol)))
 712     (epg-context-set-armor context epa-armor)
 713     (epg-context-set-textmode context epa-textmode)
 714     (epg-context-set-signers context signers)
 715     (epg-context-set-passphrase-callback context
 716                                          #'epa-passphrase-callback-function)
 717     (epg-context-set-progress-callback context
 718                                        #'epa-progress-callback-function
 719                                        (format "Signing %s..."
 720                                                (file-name-nondirectory file)))
 721     (message "Signing %s..." (file-name-nondirectory file))
 722     (epg-sign-file context file signature mode)
 723     (message "Signing %s...wrote %s" (file-name-nondirectory file)
 724              (file-name-nondirectory signature))))
 725
 726 ;;;###autoload
 727 (defun epa-encrypt-file (file recipients)
 728   "Encrypt FILE for RECIPIENTS."
 729   (interactive
 730    (list (expand-file-name (read-file-name "File: "))
 731          (epa-select-keys (epg-make-context epa-protocol)
 732                           "Select recipients for encryption.
 733 If no one is selected, symmetric encryption will be performed.  ")))
 734   (let ((cipher (concat file (if (eq epa-protocol 'OpenPGP)
 735                                  (if epa-armor ".asc" ".gpg")
 736                                ".p7m")))
 737         (context (epg-make-context epa-protocol)))
 738     (epg-context-set-armor context epa-armor)
 739     (epg-context-set-textmode context epa-textmode)
 740     (epg-context-set-passphrase-callback context
 741                                          #'epa-passphrase-callback-function)
 742     (epg-context-set-progress-callback context
 743                                        #'epa-progress-callback-function
 744                                        (format "Encrypting %s..."
 745                                                (file-name-nondirectory file)))
 746     (message "Encrypting %s..." (file-name-nondirectory file))
 747     (epg-encrypt-file context file recipients cipher)
 748     (message "Encrypting %s...wrote %s" (file-name-nondirectory file)
 749              (file-name-nondirectory cipher))))
 750
 751 ;;;###autoload
 752 (defun epa-decrypt-region (start end)
 753   "Decrypt the current region between START and END.
 754
 755 Don't use this command in Lisp programs!"
 756   (interactive "r")
 757   (save-excursion
 758     (let ((context (epg-make-context epa-protocol))
 759           plain)
 760       (epg-context-set-passphrase-callback context
 761                                            #'epa-passphrase-callback-function)
 762       (epg-context-set-progress-callback context
 763                                          #'epa-progress-callback-function
 764                                          "Decrypting...")
 765       (message "Decrypting...")
 766       (setq plain (epg-decrypt-string context (buffer-substring start end)))
 767       (message "Decrypting...done")
 768       (setq plain (epa--decode-coding-string
 769                    plain
 770                    (or coding-system-for-read
 771                        (get-text-property start 'epa-coding-system-used))))
 772       (if (y-or-n-p "Replace the original text? ")
 773           (let ((inhibit-read-only t)
 774                 buffer-read-only)
 775             (delete-region start end)
 776             (goto-char start)
 777             (insert plain))
 778         (with-output-to-temp-buffer "*Temp*"
 779           (set-buffer standard-output)
 780           (insert plain)
 781           (epa-info-mode)))
 782       (if (epg-context-result-for context 'verify)
 783           (epa-display-info (epg-verify-result-to-string
 784                              (epg-context-result-for context 'verify)))))))
 785
 786 (defun epa--find-coding-system-for-mime-charset (mime-charset)
 787   (if (featurep 'xemacs)
 788       (if (fboundp 'find-coding-system)
 789           (find-coding-system mime-charset))
 790     (let ((pointer (coding-system-list)))
 791       (while (and pointer
 792                   (eq (coding-system-get (car pointer) 'mime-charset)
 793                       mime-charset))
 794         (setq pointer (cdr pointer)))
 795       pointer)))
 796
 797 ;;;###autoload
 798 (defun epa-decrypt-armor-in-region (start end)
 799   "Decrypt OpenPGP armors in the current region between START and END.
 800
 801 Don't use this command in Lisp programs!"
 802   (interactive "r")
 803   (save-excursion
 804     (save-restriction
 805       (narrow-to-region start end)
 806       (goto-char start)
 807       (let (armor-start armor-end)
 808         (while (re-search-forward "-----BEGIN PGP MESSAGE-----$" nil t)
 809           (setq armor-start (match-beginning 0)
 810                 armor-end (re-search-forward "^-----END PGP MESSAGE-----$"
 811                                              nil t))
 812           (unless armor-end
 813             (error "No armor tail"))
 814           (goto-char armor-start)
 815           (let ((coding-system-for-read
 816                  (or coding-system-for-read
 817                      (if (re-search-forward "^Charset: \\(.*\\)" armor-end t)
 818                          (epa--find-coding-system-for-mime-charset
 819                           (intern (downcase (match-string 1))))))))
 820             (goto-char armor-end)
 821             (epa-decrypt-region armor-start armor-end)))))))
 822
 823 ;;;###autoload
 824 (defun epa-verify-region (start end)
 825   "Verify the current region between START and END.
 826
 827 Don't use this command in Lisp programs!"
 828   (interactive "r")
 829   (let ((context (epg-make-context epa-protocol))
 830         plain)
 831     (epg-context-set-progress-callback context
 832                                        #'epa-progress-callback-function
 833                                        "Verifying...")
 834     (setq plain (epg-verify-string
 835                  context
 836                  (epa--encode-coding-string
 837                   (buffer-substring start end)
 838                   (or coding-system-for-write
 839                       (get-text-property start
 840                                          'epa-coding-system-used)))))
 841     (if (y-or-n-p "Replace the original text? ")
 842         (let ((inhibit-read-only t)
 843               buffer-read-only)
 844           (delete-region start end)
 845           (goto-char start)
 846           (insert plain))
 847         (with-output-to-temp-buffer "*Temp*"
 848           (set-buffer standard-output)
 849           (insert plain)
 850           (epa-info-mode)))
 851     (if (epg-context-result-for context 'verify)
 852         (epa-display-info (epg-verify-result-to-string
 853                            (epg-context-result-for context 'verify))))))
 854
 855 ;;;###autoload
 856 (defun epa-verify-cleartext-in-region (start end)
 857   "Verify OpenPGP cleartext signed messages in the current region
 858 between START and END.
 859
 860 Don't use this command in Lisp programs!"
 861   (interactive "r")
 862   (save-excursion
 863     (save-restriction
 864       (narrow-to-region start end)
 865       (goto-char start)
 866       (let (cleartext-start cleartext-end)
 867         (while (re-search-forward "-----BEGIN PGP SIGNED MESSAGE-----$"
 868                                   nil t)
 869           (setq cleartext-start (match-beginning 0))
 870           (unless (re-search-forward "^-----BEGIN PGP SIGNATURE-----$"
 871                                            nil t)
 872             (error "Invalid cleartext signed message"))
 873           (setq cleartext-end (re-search-forward
 874                            "^-----END PGP SIGNATURE-----$"
 875                            nil t))
 876           (unless cleartext-end
 877             (error "No cleartext tail"))
 878           (epa-verify-region cleartext-start cleartext-end))))))
 879
 880 (if (fboundp 'select-safe-coding-system)
 881     (defalias 'epa--select-safe-coding-system 'select-safe-coding-system)
 882   (defun epa--select-safe-coding-system (from to)
 883     buffer-file-coding-system))
 884
 885 ;;;###autoload
 886 (defun epa-sign-region (start end signers mode)
 887   "Sign the current region between START and END by SIGNERS keys selected.
 888
 889 Don't use this command in Lisp programs!"
 890   (interactive
 891    (let ((verbose current-prefix-arg))
 892      (setq epa-last-coding-system-specified
 893            (or coding-system-for-write
 894                (epa--select-safe-coding-system
 895                 (region-beginning) (region-end))))
 896      (list (region-beginning) (region-end)
 897            (if verbose
 898                (epa-select-keys (epg-make-context epa-protocol)
 899                                 "Select keys for signing.
 900 If no one is selected, default secret key is used.  "
 901                                 nil t))
 902            (if verbose
 903                (epa--read-signature-type)
 904              'clear))))
 905   (save-excursion
 906     (let ((context (epg-make-context epa-protocol))
 907           signature)
 908       ;;(epg-context-set-armor context epa-armor)
 909       (epg-context-set-armor context t)
 910       ;;(epg-context-set-textmode context epa-textmode)
 911       (epg-context-set-textmode context t)
 912       (epg-context-set-signers context signers)
 913       (epg-context-set-passphrase-callback context
 914                                            #'epa-passphrase-callback-function)
 915       (epg-context-set-progress-callback context
 916                                          #'epa-progress-callback-function
 917                                          "Signing...")
 918       (message "Signing...")
 919       (setq signature (epg-sign-string context
 920                                        (epa--encode-coding-string
 921                                         (buffer-substring start end)
 922                                         epa-last-coding-system-specified)
 923                                        mode))
 924       (message "Signing...done")
 925       (delete-region start end)
 926       (goto-char start)
 927       (add-text-properties (point)
 928                            (progn
 929                              (insert (epa--decode-coding-string
 930                                       signature
 931                                       (or coding-system-for-read
 932                                           epa-last-coding-system-specified)))
 933                              (point))
 934                            (list 'epa-coding-system-used
 935                                  epa-last-coding-system-specified
 936                                  'front-sticky nil
 937                                  'rear-nonsticky t
 938                                  'start-open t
 939                                  'end-open t)))))
 940
 941 (if (fboundp 'derived-mode-p)
 942     (defalias 'epa--derived-mode-p 'derived-mode-p)
 943   (defun epa--derived-mode-p (&rest modes)
 944     "Non-nil if the current major mode is derived from one of MODES.
 945 Uses the `derived-mode-parent' property of the symbol to trace backwards."
 946     (let ((parent major-mode))
 947       (while (and (not (memq parent modes))
 948                   (setq parent (get parent 'derived-mode-parent))))
 949       parent)))
 950
 951 ;;;###autoload
 952 (defun epa-encrypt-region (start end recipients sign signers)
 953   "Encrypt the current region between START and END for RECIPIENTS.
 954
 955 Don't use this command in Lisp programs!"
 956   (interactive
 957    (let ((verbose current-prefix-arg)
 958          (context (epg-make-context epa-protocol))
 959          sign)
 960      (setq epa-last-coding-system-specified
 961            (or coding-system-for-write
 962                (epa--select-safe-coding-system
 963                 (region-beginning) (region-end))))
 964      (list (region-beginning) (region-end)
 965            (epa-select-keys context
 966                             "Select recipients for encryption.
 967 If no one is selected, symmetric encryption will be performed.  ")
 968            (setq sign (if verbose (y-or-n-p "Sign? ")))
 969            (if sign
 970                (epa-select-keys context
 971                                 "Select keys for signing.  ")))))
 972   (save-excursion
 973     (let ((context (epg-make-context epa-protocol))
 974           cipher)
 975       ;;(epg-context-set-armor context epa-armor)
 976       (epg-context-set-armor context t)
 977       ;;(epg-context-set-textmode context epa-textmode)
 978       (epg-context-set-textmode context t)
 979       (if sign
 980           (epg-context-set-signers context signers))
 981       (epg-context-set-passphrase-callback context
 982                                            #'epa-passphrase-callback-function)
 983       (epg-context-set-progress-callback context
 984                                          #'epa-progress-callback-function
 985                                          "Encrypting...")
 986       (message "Encrypting...")
 987       (setq cipher (epg-encrypt-string context
 988                                        (epa--encode-coding-string
 989                                         (buffer-substring start end)
 990                                         epa-last-coding-system-specified)
 991                                        recipients
 992                                        sign))
 993       (message "Encrypting...done")
 994       (delete-region start end)
 995       (goto-char start)
 996       (add-text-properties (point)
 997                            (progn
 998                              (insert cipher)
 999                              (point))
1000                            (list 'epa-coding-system-used
1001                                  epa-last-coding-system-specified
1002                                  'front-sticky nil
1003                                  'rear-nonsticky t
1004                                  'start-open t
1005                                  'end-open t)))))
1006
1007 ;;;###autoload
1008 (defun epa-delete-keys (keys &optional allow-secret)
1009   "Delete selected KEYS.
1010
1011 Don't use this command in Lisp programs!"
1012   (interactive
1013    (let ((keys (epa--marked-keys)))
1014      (unless keys
1015        (error "No keys selected"))
1016      (list keys
1017            (eq (nth 1 epa-list-keys-arguments) t))))
1018   (let ((context (epg-make-context epa-protocol)))
1019     (message "Deleting...")
1020     (epg-delete-keys context keys allow-secret)
1021     (message "Deleting...done")
1022     (apply #'epa-list-keys epa-list-keys-arguments)))
1023
1024 ;;;###autoload
1025 (defun epa-import-keys (file)
1026   "Import keys from FILE.
1027
1028 Don't use this command in Lisp programs!"
1029   (interactive "fFile: ")
1030   (setq file (expand-file-name file))
1031   (let ((context (epg-make-context epa-protocol)))
1032     (message "Importing %s..." (file-name-nondirectory file))
1033     (condition-case nil
1034         (progn
1035           (epg-import-keys-from-file context file)
1036           (message "Importing %s...done" (file-name-nondirectory file)))
1037       (error
1038        (message "Importing %s...failed" (file-name-nondirectory file))))
1039     (if (epg-context-result-for context 'import)
1040         (epa-display-info (epg-import-result-to-string
1041                            (epg-context-result-for context 'import))))
1042     (if (eq major-mode 'epa-key-list-mode)
1043         (apply #'epa-list-keys epa-list-keys-arguments))))
1044
1045 ;;;###autoload
1046 (defun epa-import-keys-region (start end)
1047   "Import keys from the region.
1048
1049 Don't use this command in Lisp programs!"
1050   (interactive "r")
1051   (let ((context (epg-make-context epa-protocol)))
1052     (message "Importing...")
1053     (condition-case nil
1054         (progn
1055           (epg-import-keys-from-string context (buffer-substring start end))
1056           (message "Importing...done"))
1057       (error
1058        (message "Importing...failed")))
1059     (if (epg-context-result-for context 'import)
1060         (epa-display-info (epg-import-result-to-string
1061                            (epg-context-result-for context 'import))))))
1062
1063 ;;;###autoload
1064 (defun epa-import-armor-in-region (start end)
1065   "Import keys in the OpenPGP armor format in the current region
1066 between START and END.
1067
1068 Don't use this command in Lisp programs!"
1069   (interactive "r")
1070   (save-excursion
1071     (save-restriction
1072       (narrow-to-region start end)
1073       (goto-char start)
1074       (let (armor-start armor-end)
1075         (while (re-search-forward
1076                 "-----BEGIN \\(PGP \\(PUBLIC\\|PRIVATE\\) KEY BLOCK\\)-----$"
1077                 nil t)
1078           (setq armor-start (match-beginning 0)
1079                 armor-end (re-search-forward
1080                            (concat "^-----END " (match-string 1) "-----$")
1081                            nil t))
1082           (unless armor-end
1083             (error "No armor tail"))
1084           (epa-import-keys-region armor-start armor-end))))))
1085
1086 ;;;###autoload
1087 (defun epa-export-keys (keys file)
1088   "Export selected KEYS to FILE.
1089
1090 Don't use this command in Lisp programs!"
1091   (interactive
1092    (let ((keys (epa--marked-keys))
1093          default-name)
1094      (unless keys
1095        (error "No keys selected"))
1096      (setq default-name
1097            (expand-file-name
1098             (concat (epg-sub-key-id (car (epg-key-sub-key-list (car keys))))
1099                     (if epa-armor ".asc" ".gpg"))
1100             default-directory))
1101      (list keys
1102            (expand-file-name
1103             (read-file-name
1104              (concat "To file (default "
1105                      (file-name-nondirectory default-name)
1106                      ") ")
1107              (file-name-directory default-name)
1108              default-name)))))
1109   (let ((context (epg-make-context epa-protocol)))
1110     (epg-context-set-armor context epa-armor)
1111     (message "Exporting to %s..." (file-name-nondirectory file))
1112     (epg-export-keys-to-file context keys file)
1113     (message "Exporting to %s...done" (file-name-nondirectory file))))
1114
1115 ;;;###autoload
1116 (defun epa-insert-keys (keys)
1117   "Insert selected KEYS after the point.
1118
1119 Don't use this command in Lisp programs!"
1120   (interactive
1121    (list (epa-select-keys (epg-make-context epa-protocol)
1122                           "Select keys to export.  ")))
1123   (let ((context (epg-make-context epa-protocol)))
1124     ;;(epg-context-set-armor context epa-armor)
1125     (epg-context-set-armor context t)
1126     (insert (epg-export-keys-to-string context keys))))
1127
1128 ;;;###autoload
1129 (defun epa-sign-keys (keys &optional local)
1130   "Sign selected KEYS.
1131 If a prefix-arg is specified, the signature is marked as non exportable.
1132
1133 Don't use this command in Lisp programs!"
1134   (interactive
1135    (let ((keys (epa--marked-keys)))
1136      (unless keys
1137        (error "No keys selected"))
1138      (list keys current-prefix-arg)))
1139   (let ((context (epg-make-context epa-protocol)))
1140     (epg-context-set-passphrase-callback context
1141                                          #'epa-passphrase-callback-function)
1142     (epg-context-set-progress-callback context
1143                                        #'epa-progress-callback-function
1144                                        "Signing keys...")
1145     (message "Signing keys...")
1146     (epg-sign-keys context keys local)
1147     (message "Signing keys...done")))
1148 (make-obsolete 'epa-sign-keys "Do not use.")
1149
1150 (provide 'epa)
1151
1152 ;;; epa.el ends here