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)
 181     (define-key keymap "u" 'epa-unmark)
 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 (&optional arg)
 305   "Mark the current line.
 306 If ARG is non-nil, unmark the current line."
 307   (interactive "P")
 308   (let ((inhibit-read-only t)
 309         buffer-read-only
 310         properties)
 311     (beginning-of-line)
 312     (setq properties (text-properties-at (point)))
 313     (delete-char 1)
 314     (insert (if arg " " "*"))
 315     (set-text-properties (1- (point)) (point) properties)
 316     (forward-line)))
 317
 318 (defun epa-unmark (&optional arg)
 319   "Unmark the current line.
 320 If ARG is non-nil, mark the current line."
 321   (interactive "P")
 322   (epa-mark (not arg)))
 323
 324 (defun epa-toggle-mark ()
 325   "Toggle the mark the current line."
 326   (interactive)
 327   (epa-mark (eq (char-after (save-excursion (beginning-of-line) (point))) ?*)))
 328
 329 (defun epa-exit-buffer ()
 330   "Exit the current buffer.
 331 `epa-exit-buffer-function' is called if it is set."
 332   (interactive)
 333   (funcall epa-exit-buffer-function))
 334
 335 (defun epa--insert-keys (keys)
 336   (save-excursion
 337     (save-restriction
 338       (narrow-to-region (point) (point))
 339       (let (point)
 340         (while keys
 341           (setq point (point))
 342           (insert "  ")
 343           (add-text-properties point (point)
 344                                (list 'epa-key (car keys)
 345                                      'front-sticky nil
 346                                      'rear-nonsticky t
 347                                      'start-open t
 348                                      'end-open t))
 349           (widget-create 'epa-key :value (car keys))
 350           (insert "\n")
 351           (setq keys (cdr keys))))
 352       (add-text-properties (point-min) (point-max)
 353                            (list 'epa-list-keys t
 354                                  'front-sticky nil
 355                                  'rear-nonsticky t
 356                                  'start-open t
 357                                  'end-open t)))))
 358
 359 (defun epa--list-keys (name secret)
 360   (unless (and epa-keys-buffer
 361                (buffer-live-p epa-keys-buffer))
 362     (setq epa-keys-buffer (generate-new-buffer "*Keys*")))
 363   (set-buffer epa-keys-buffer)
 364   (epa-key-list-mode)
 365   (let ((inhibit-read-only t)
 366         buffer-read-only
 367         (point (point-min))
 368         (context (epg-make-context epa-protocol)))
 369     (unless (get-text-property point 'epa-list-keys)
 370       (setq point (next-single-property-change point 'epa-list-keys)))
 371     (when point
 372       (delete-region point
 373                      (or (next-single-property-change point 'epa-list-keys)
 374                          (point-max)))
 375       (goto-char point))
 376     (epa--insert-keys (epg-list-keys context name secret))
 377     (widget-setup)
 378     (set-keymap-parent (current-local-map) widget-keymap))
 379   (make-local-variable 'epa-list-keys-arguments)
 380   (setq epa-list-keys-arguments (list name secret))
 381   (goto-char (point-min))
 382   (pop-to-buffer (current-buffer)))
 383
 384 ;;;###autoload
 385 (defun epa-list-keys (&optional name)
 386   "List all keys matched with NAME from the public keyring."
 387   (interactive
 388    (if current-prefix-arg
 389        (let ((name (read-string "Pattern: "
 390                                 (if epa-list-keys-arguments
 391                                     (car epa-list-keys-arguments)))))
 392          (list (if (equal name "") nil name)))
 393      (list nil)))
 394   (epa--list-keys name nil))
 395
 396 ;;;###autoload
 397 (defun epa-list-secret-keys (&optional name)
 398   "List all keys matched with NAME from the private keyring."
 399   (interactive
 400    (if current-prefix-arg
 401        (let ((name (read-string "Pattern: "
 402                                 (if epa-list-keys-arguments
 403                                     (car epa-list-keys-arguments)))))
 404          (list (if (equal name "") nil name)))
 405      (list nil)))
 406   (epa--list-keys name t))
 407
 408 (defun epa--key-list-revert-buffer (&optional ignore-auto noconfirm)
 409   (apply #'epa--list-keys epa-list-keys-arguments))
 410
 411 (defun epa--marked-keys ()
 412   (or (save-excursion
 413         (set-buffer epa-keys-buffer)
 414         (goto-char (point-min))
 415         (let (keys key)
 416           (while (re-search-forward "^\\*" nil t)
 417             (if (setq key (get-text-property (match-beginning 0)
 418                                              'epa-key))
 419                 (setq keys (cons key keys))))
 420           (nreverse keys)))
 421       (save-excursion
 422         (beginning-of-line)
 423         (let ((key (get-text-property (point) 'epa-key)))
 424           (if key
 425               (list key))))))
 426
 427 (defun epa--select-keys (prompt keys)
 428   (save-excursion
 429     (unless (and epa-keys-buffer
 430                  (buffer-live-p epa-keys-buffer))
 431       (setq epa-keys-buffer (generate-new-buffer "*Keys*")))
 432     (set-buffer epa-keys-buffer)
 433     (epa-key-list-mode)
 434     (let ((inhibit-read-only t)
 435           buffer-read-only)
 436       (erase-buffer)
 437       (insert prompt "\n"
 438               (substitute-command-keys "\
 439 - `\\[epa-mark]' to mark a key on the line
 440 - `\\[epa-unmark]' to unmark a key on the line\n"))
 441       (widget-create 'link
 442                      :notify (lambda (&rest ignore) (abort-recursive-edit))
 443                      :help-echo
 444                      (substitute-command-keys
 445                       "Click here or \\[abort-recursive-edit] to cancel")
 446                      "Cancel")
 447       (widget-create 'link
 448                      :notify (lambda (&rest ignore) (exit-recursive-edit))
 449                      :help-echo
 450                      (substitute-command-keys
 451                       "Click here or \\[exit-recursive-edit] to finish")
 452                      "OK")
 453       (insert "\n\n")
 454       (epa--insert-keys keys)
 455       (widget-setup)
 456       (set-keymap-parent (current-local-map) widget-keymap)
 457       (setq epa-exit-buffer-function #'abort-recursive-edit)
 458       (goto-char (point-min))
 459       (pop-to-buffer (current-buffer)))
 460     (unwind-protect
 461         (progn
 462           (recursive-edit)
 463           (epa--marked-keys))
 464       (if (get-buffer-window epa-keys-buffer)
 465           (delete-window (get-buffer-window epa-keys-buffer)))
 466       (kill-buffer epa-keys-buffer))))
 467
 468 ;;;###autoload
 469 (defun epa-select-keys (context prompt &optional names secret)
 470   "Display a user's keyring and ask him to select keys.
 471 CONTEXT is an epg-context.
 472 PROMPT is a string to prompt with.
 473 NAMES is a list of strings to be matched with keys.  If it is nil, all
 474 the keys are listed.
 475 If SECRET is non-nil, list secret keys instead of public keys."
 476   (let ((keys (epg-list-keys context names secret)))
 477     (if (> (length keys) 1)
 478         (epa--select-keys prompt keys)
 479       keys)))
 480
 481 (defun epa--format-fingerprint-1 (fingerprint unit-size block-size)
 482   (let ((unit 0))
 483     (with-temp-buffer
 484       (insert fingerprint)
 485       (goto-char (point-min))
 486       (while (progn
 487                (goto-char (+ (point) unit-size))
 488                (not (eobp)))
 489         (setq unit (1+ unit))
 490         (insert (if (= (% unit block-size) 0) "  " " ")))
 491       (buffer-string))))
 492
 493 (defun epa--format-fingerprint (fingerprint)
 494   (if fingerprint
 495       (if (= (length fingerprint) 40)
 496           ;; 1234 5678 9ABC DEF0 1234  5678 9ABC DEF0 1234 5678
 497           (epa--format-fingerprint-1 fingerprint 4 5)
 498         ;; 12 34 56 78 9A BC DE F0  12 34 56 78 9A BC DE F0
 499         (epa--format-fingerprint-1 fingerprint 2 8))))
 500
 501 (defun epa--show-key (key)
 502   (let* ((primary-sub-key (car (epg-key-sub-key-list key)))
 503          (entry (assoc (epg-sub-key-id primary-sub-key)
 504                        epa-key-buffer-alist))
 505          (inhibit-read-only t)
 506          buffer-read-only
 507          pointer)
 508     (unless entry
 509       (setq entry (cons (epg-sub-key-id primary-sub-key) nil)
 510             epa-key-buffer-alist (cons entry epa-key-buffer-alist)))
 511     (unless (and (cdr entry)
 512                  (buffer-live-p (cdr entry)))
 513       (setcdr entry (generate-new-buffer
 514                      (format "*Key*%s" (epg-sub-key-id primary-sub-key)))))
 515     (set-buffer (cdr entry))
 516     (epa-key-mode)
 517     (make-local-variable 'epa-key)
 518     (setq epa-key key)
 519     (erase-buffer)
 520     (setq pointer (epg-key-user-id-list key))
 521     (while pointer
 522       (if (car pointer)
 523           (insert " "
 524                   (if (epg-user-id-validity (car pointer))
 525                       (char-to-string
 526                        (car (rassq (epg-user-id-validity (car pointer))
 527                                    epg-key-validity-alist)))
 528                     " ")
 529                   " "
 530                   (if (stringp (epg-user-id-string (car pointer)))
 531                       (epg-user-id-string (car pointer))
 532                     (epg-decode-dn (epg-user-id-string (car pointer))))
 533                   "\n"))
 534       (setq pointer (cdr pointer)))
 535     (setq pointer (epg-key-sub-key-list key))
 536     (while pointer
 537       (insert " "
 538               (if (epg-sub-key-validity (car pointer))
 539                   (char-to-string
 540                    (car (rassq (epg-sub-key-validity (car pointer))
 541                                epg-key-validity-alist)))
 542                 " ")
 543               " "
 544               (epg-sub-key-id (car pointer))
 545               " "
 546               (format "%dbits"
 547                       (epg-sub-key-length (car pointer)))
 548               " "
 549               (cdr (assq (epg-sub-key-algorithm (car pointer))
 550                          epg-pubkey-algorithm-alist))
 551               "\n\tCreated: "
 552               (format-time-string "%Y-%m-%d"
 553                                   (epg-sub-key-creation-time (car pointer)))
 554               (if (epg-sub-key-expiration-time (car pointer))
 555                   (format "\n\tExpires: %s"
 556                           (format-time-string "%Y-%m-%d"
 557                                               (epg-sub-key-expiration-time
 558                                                (car pointer))))
 559                 "")
 560               "\n\tCapabilities: "
 561               (mapconcat #'symbol-name
 562                          (epg-sub-key-capability (car pointer))
 563                          " ")
 564               "\n\tFingerprint: "
 565               (epa--format-fingerprint (epg-sub-key-fingerprint (car pointer)))
 566               "\n")
 567       (setq pointer (cdr pointer)))
 568     (goto-char (point-min))
 569     (pop-to-buffer (current-buffer))))
 570
 571 (defun epa-display-info (info)
 572   (if epa-popup-info-window
 573       (save-selected-window
 574         (unless (and epa-info-buffer (buffer-live-p epa-info-buffer))
 575           (setq epa-info-buffer (generate-new-buffer "*Info*")))
 576         (if (get-buffer-window epa-info-buffer)
 577             (delete-window (get-buffer-window epa-info-buffer)))
 578         (save-excursion
 579           (set-buffer epa-info-buffer)
 580           (let ((inhibit-read-only t)
 581                 buffer-read-only)
 582             (erase-buffer)
 583             (insert info))
 584           (epa-info-mode)
 585           (goto-char (point-min)))
 586         (if (> (window-height)
 587                epa-info-window-height)
 588             (set-window-buffer (split-window nil (- (window-height)
 589                                                     epa-info-window-height))
 590                                epa-info-buffer)
 591           (pop-to-buffer epa-info-buffer)
 592           (if (> (window-height) epa-info-window-height)
 593               (shrink-window (- (window-height) epa-info-window-height)))))
 594     (message "%s" info)))
 595
 596 (defun epa-display-verify-result (verify-result)
 597   (epa-display-info (epg-verify-result-to-string verify-result)))
 598 (make-obsolete 'epa-display-verify-result 'epa-display-info)
 599
 600 (defun epa-passphrase-callback-function (context key-id handback)
 601   (if (eq key-id 'SYM)
 602       (read-passwd "Passphrase for symmetric encryption: "
 603                    (eq (epg-context-operation context) 'encrypt))
 604     (read-passwd
 605      (if (eq key-id 'PIN)
 606         "Passphrase for PIN: "
 607        (let ((entry (assoc key-id epg-user-id-alist)))
 608          (if entry
 609              (format "Passphrase for %s %s: " key-id (cdr entry))
 610            (format "Passphrase for %s: " key-id)))))))
 611
 612 (defun epa-progress-callback-function (context what char current total
 613                                                handback)
 614   (message "%s%d%% (%d/%d)" (or handback
 615                                 (concat what ": "))
 616            (if (> total 0) (floor (* (/ current (float total)) 100)) 0)
 617            current total))
 618
 619 ;;;###autoload
 620 (defun epa-decrypt-file (file)
 621   "Decrypt FILE."
 622   (interactive "fFile: ")
 623   (setq file (expand-file-name file))
 624   (let* ((default-name (file-name-sans-extension file))
 625          (plain (expand-file-name
 626                  (read-file-name
 627                   (concat "To file (default "
 628                           (file-name-nondirectory default-name)
 629                           ") ")
 630                   (file-name-directory default-name)
 631                   default-name)))
 632          (context (epg-make-context epa-protocol)))
 633     (epg-context-set-passphrase-callback context
 634                                          #'epa-passphrase-callback-function)
 635     (epg-context-set-progress-callback context
 636                                        #'epa-progress-callback-function
 637                                        (format "Decrypting %s..."
 638                                                (file-name-nondirectory file)))
 639     (message "Decrypting %s..." (file-name-nondirectory file))
 640     (epg-decrypt-file context file plain)
 641     (message "Decrypting %s...wrote %s" (file-name-nondirectory file)
 642              (file-name-nondirectory plain))
 643     (if (epg-context-result-for context 'verify)
 644         (epa-display-info (epg-verify-result-to-string
 645                            (epg-context-result-for context 'verify))))))
 646
 647 ;;;###autoload
 648 (defun epa-verify-file (file)
 649   "Verify FILE."
 650   (interactive "fFile: ")
 651   (setq file (expand-file-name file))
 652   (let* ((context (epg-make-context epa-protocol))
 653          (plain (if (equal (file-name-extension file) "sig")
 654                     (file-name-sans-extension file))))
 655     (epg-context-set-progress-callback context
 656                                        #'epa-progress-callback-function
 657                                        (format "Verifying %s..."
 658                                                (file-name-nondirectory file)))
 659     (message "Verifying %s..." (file-name-nondirectory file))
 660     (epg-verify-file context file plain)
 661     (message "Verifying %s...done" (file-name-nondirectory file))
 662     (if (epg-context-result-for context 'verify)
 663         (epa-display-info (epg-verify-result-to-string
 664                            (epg-context-result-for context 'verify))))))
 665
 666 (defun epa--read-signature-type ()
 667   (let (type c)
 668     (while (null type)
 669       (message "Signature type (n,c,d,?) ")
 670       (setq c (read-char))
 671       (cond ((eq c ?c)
 672              (setq type 'clear))
 673             ((eq c ?d)
 674              (setq type 'detached))
 675             ((eq c ??)
 676              (with-output-to-temp-buffer "*Help*"
 677                (save-excursion
 678                  (set-buffer standard-output)
 679                  (insert "\
 680 n - Create a normal signature
 681 c - Create a cleartext signature
 682 d - Create a detached signature
 683 ? - Show this help
 684 "))))
 685             (t
 686              (setq type 'normal))))))
 687
 688 ;;;###autoload
 689 (defun epa-sign-file (file signers mode)
 690   "Sign FILE by SIGNERS keys selected."
 691   (interactive
 692    (let ((verbose current-prefix-arg))
 693      (list (expand-file-name (read-file-name "File: "))
 694            (if verbose
 695                (epa-select-keys (epg-make-context epa-protocol)
 696                                 "Select keys for signing.
 697 If no one is selected, default secret key is used.  "
 698                                 nil t))
 699            (if verbose
 700                (epa--read-signature-type)
 701              'clear))))
 702   (let ((signature (concat file
 703                            (if (eq epa-protocol 'OpenPGP)
 704                                (if (or epa-armor
 705                                        (not (memq mode
 706                                                   '(nil t normal detached))))
 707                                    ".asc"
 708                                  (if (memq mode '(t detached))
 709                                      ".sig"
 710                                    ".gpg"))
 711                              (if (memq mode '(t detached))
 712                                  ".p7s"
 713                                ".p7m"))))
 714         (context (epg-make-context epa-protocol)))
 715     (epg-context-set-armor context epa-armor)
 716     (epg-context-set-textmode context epa-textmode)
 717     (epg-context-set-signers context signers)
 718     (epg-context-set-passphrase-callback context
 719                                          #'epa-passphrase-callback-function)
 720     (epg-context-set-progress-callback context
 721                                        #'epa-progress-callback-function
 722                                        (format "Signing %s..."
 723                                                (file-name-nondirectory file)))
 724     (message "Signing %s..." (file-name-nondirectory file))
 725     (epg-sign-file context file signature mode)
 726     (message "Signing %s...wrote %s" (file-name-nondirectory file)
 727              (file-name-nondirectory signature))))
 728
 729 ;;;###autoload
 730 (defun epa-encrypt-file (file recipients)
 731   "Encrypt FILE for RECIPIENTS."
 732   (interactive
 733    (list (expand-file-name (read-file-name "File: "))
 734          (epa-select-keys (epg-make-context epa-protocol)
 735                           "Select recipients for encryption.
 736 If no one is selected, symmetric encryption will be performed.  ")))
 737   (let ((cipher (concat file (if (eq epa-protocol 'OpenPGP)
 738                                  (if epa-armor ".asc" ".gpg")
 739                                ".p7m")))
 740         (context (epg-make-context epa-protocol)))
 741     (epg-context-set-armor context epa-armor)
 742     (epg-context-set-textmode context epa-textmode)
 743     (epg-context-set-passphrase-callback context
 744                                          #'epa-passphrase-callback-function)
 745     (epg-context-set-progress-callback context
 746                                        #'epa-progress-callback-function
 747                                        (format "Encrypting %s..."
 748                                                (file-name-nondirectory file)))
 749     (message "Encrypting %s..." (file-name-nondirectory file))
 750     (epg-encrypt-file context file recipients cipher)
 751     (message "Encrypting %s...wrote %s" (file-name-nondirectory file)
 752              (file-name-nondirectory cipher))))
 753
 754 ;;;###autoload
 755 (defun epa-decrypt-region (start end)
 756   "Decrypt the current region between START and END.
 757
 758 Don't use this command in Lisp programs!"
 759   (interactive "r")
 760   (save-excursion
 761     (let ((context (epg-make-context epa-protocol))
 762           plain)
 763       (epg-context-set-passphrase-callback context
 764                                            #'epa-passphrase-callback-function)
 765       (epg-context-set-progress-callback context
 766                                          #'epa-progress-callback-function
 767                                          "Decrypting...")
 768       (message "Decrypting...")
 769       (setq plain (epg-decrypt-string context (buffer-substring start end)))
 770       (message "Decrypting...done")
 771       (setq plain (epa--decode-coding-string
 772                    plain
 773                    (or coding-system-for-read
 774                        (get-text-property start 'epa-coding-system-used))))
 775       (if (y-or-n-p "Replace the original text? ")
 776           (let ((inhibit-read-only t)
 777                 buffer-read-only)
 778             (delete-region start end)
 779             (goto-char start)
 780             (insert plain))
 781         (with-output-to-temp-buffer "*Temp*"
 782           (set-buffer standard-output)
 783           (insert plain)
 784           (epa-info-mode)))
 785       (if (epg-context-result-for context 'verify)
 786           (epa-display-info (epg-verify-result-to-string
 787                              (epg-context-result-for context 'verify)))))))
 788
 789 (defun epa--find-coding-system-for-mime-charset (mime-charset)
 790   (if (featurep 'xemacs)
 791       (if (fboundp 'find-coding-system)
 792           (find-coding-system mime-charset))
 793     (let ((pointer (coding-system-list)))
 794       (while (and pointer
 795                   (eq (coding-system-get (car pointer) 'mime-charset)
 796                       mime-charset))
 797         (setq pointer (cdr pointer)))
 798       pointer)))
 799
 800 ;;;###autoload
 801 (defun epa-decrypt-armor-in-region (start end)
 802   "Decrypt OpenPGP armors in the current region between START and END.
 803
 804 Don't use this command in Lisp programs!"
 805   (interactive "r")
 806   (save-excursion
 807     (save-restriction
 808       (narrow-to-region start end)
 809       (goto-char start)
 810       (let (armor-start armor-end)
 811         (while (re-search-forward "-----BEGIN PGP MESSAGE-----$" nil t)
 812           (setq armor-start (match-beginning 0)
 813                 armor-end (re-search-forward "^-----END PGP MESSAGE-----$"
 814                                              nil t))
 815           (unless armor-end
 816             (error "No armor tail"))
 817           (goto-char armor-start)
 818           (let ((coding-system-for-read
 819                  (or coding-system-for-read
 820                      (if (re-search-forward "^Charset: \\(.*\\)" armor-end t)
 821                          (epa--find-coding-system-for-mime-charset
 822                           (intern (downcase (match-string 1))))))))
 823             (goto-char armor-end)
 824             (epa-decrypt-region armor-start armor-end)))))))
 825
 826 ;;;###autoload
 827 (defun epa-verify-region (start end)
 828   "Verify the current region between START and END.
 829
 830 Don't use this command in Lisp programs!"
 831   (interactive "r")
 832   (let ((context (epg-make-context epa-protocol))
 833         plain)
 834     (epg-context-set-progress-callback context
 835                                        #'epa-progress-callback-function
 836                                        "Verifying...")
 837     (setq plain (epg-verify-string
 838                  context
 839                  (epa--encode-coding-string
 840                   (buffer-substring start end)
 841                   (or coding-system-for-write
 842                       (get-text-property start
 843                                          'epa-coding-system-used)))))
 844     (if (y-or-n-p "Replace the original text? ")
 845         (let ((inhibit-read-only t)
 846               buffer-read-only)
 847           (delete-region start end)
 848           (goto-char start)
 849           (insert plain))
 850         (with-output-to-temp-buffer "*Temp*"
 851           (set-buffer standard-output)
 852           (insert plain)
 853           (epa-info-mode)))
 854     (if (epg-context-result-for context 'verify)
 855         (epa-display-info (epg-verify-result-to-string
 856                            (epg-context-result-for context 'verify))))))
 857
 858 ;;;###autoload
 859 (defun epa-verify-cleartext-in-region (start end)
 860   "Verify OpenPGP cleartext signed messages in the current region
 861 between START and END.
 862
 863 Don't use this command in Lisp programs!"
 864   (interactive "r")
 865   (save-excursion
 866     (save-restriction
 867       (narrow-to-region start end)
 868       (goto-char start)
 869       (let (cleartext-start cleartext-end)
 870         (while (re-search-forward "-----BEGIN PGP SIGNED MESSAGE-----$"
 871                                   nil t)
 872           (setq cleartext-start (match-beginning 0))
 873           (unless (re-search-forward "^-----BEGIN PGP SIGNATURE-----$"
 874                                            nil t)
 875             (error "Invalid cleartext signed message"))
 876           (setq cleartext-end (re-search-forward
 877                            "^-----END PGP SIGNATURE-----$"
 878                            nil t))
 879           (unless cleartext-end
 880             (error "No cleartext tail"))
 881           (epa-verify-region cleartext-start cleartext-end))))))
 882
 883 (if (fboundp 'select-safe-coding-system)
 884     (defalias 'epa--select-safe-coding-system 'select-safe-coding-system)
 885   (defun epa--select-safe-coding-system (from to)
 886     buffer-file-coding-system))
 887
 888 ;;;###autoload
 889 (defun epa-sign-region (start end signers mode)
 890   "Sign the current region between START and END by SIGNERS keys selected.
 891
 892 Don't use this command in Lisp programs!"
 893   (interactive
 894    (let ((verbose current-prefix-arg))
 895      (setq epa-last-coding-system-specified
 896            (or coding-system-for-write
 897                (epa--select-safe-coding-system
 898                 (region-beginning) (region-end))))
 899      (list (region-beginning) (region-end)
 900            (if verbose
 901                (epa-select-keys (epg-make-context epa-protocol)
 902                                 "Select keys for signing.
 903 If no one is selected, default secret key is used.  "
 904                                 nil t))
 905            (if verbose
 906                (epa--read-signature-type)
 907              'clear))))
 908   (save-excursion
 909     (let ((context (epg-make-context epa-protocol))
 910           signature)
 911       ;;(epg-context-set-armor context epa-armor)
 912       (epg-context-set-armor context t)
 913       ;;(epg-context-set-textmode context epa-textmode)
 914       (epg-context-set-textmode context t)
 915       (epg-context-set-signers context signers)
 916       (epg-context-set-passphrase-callback context
 917                                            #'epa-passphrase-callback-function)
 918       (epg-context-set-progress-callback context
 919                                          #'epa-progress-callback-function
 920                                          "Signing...")
 921       (message "Signing...")
 922       (setq signature (epg-sign-string context
 923                                        (epa--encode-coding-string
 924                                         (buffer-substring start end)
 925                                         epa-last-coding-system-specified)
 926                                        mode))
 927       (message "Signing...done")
 928       (delete-region start end)
 929       (goto-char start)
 930       (add-text-properties (point)
 931                            (progn
 932                              (insert (epa--decode-coding-string
 933                                       signature
 934                                       (or coding-system-for-read
 935                                           epa-last-coding-system-specified)))
 936                              (point))
 937                            (list 'epa-coding-system-used
 938                                  epa-last-coding-system-specified
 939                                  'front-sticky nil
 940                                  'rear-nonsticky t
 941                                  'start-open t
 942                                  'end-open t)))))
 943
 944 (if (fboundp 'derived-mode-p)
 945     (defalias 'epa--derived-mode-p 'derived-mode-p)
 946   (defun epa--derived-mode-p (&rest modes)
 947     "Non-nil if the current major mode is derived from one of MODES.
 948 Uses the `derived-mode-parent' property of the symbol to trace backwards."
 949     (let ((parent major-mode))
 950       (while (and (not (memq parent modes))
 951                   (setq parent (get parent 'derived-mode-parent))))
 952       parent)))
 953
 954 ;;;###autoload
 955 (defun epa-encrypt-region (start end recipients sign signers)
 956   "Encrypt the current region between START and END for RECIPIENTS.
 957
 958 Don't use this command in Lisp programs!"
 959   (interactive
 960    (let ((verbose current-prefix-arg)
 961          (context (epg-make-context epa-protocol))
 962          sign)
 963      (setq epa-last-coding-system-specified
 964            (or coding-system-for-write
 965                (epa--select-safe-coding-system
 966                 (region-beginning) (region-end))))
 967      (list (region-beginning) (region-end)
 968            (epa-select-keys context
 969                             "Select recipients for encryption.
 970 If no one is selected, symmetric encryption will be performed.  ")
 971            (setq sign (if verbose (y-or-n-p "Sign? ")))
 972            (if sign
 973                (epa-select-keys context
 974                                 "Select keys for signing.  ")))))
 975   (save-excursion
 976     (let ((context (epg-make-context epa-protocol))
 977           cipher)
 978       ;;(epg-context-set-armor context epa-armor)
 979       (epg-context-set-armor context t)
 980       ;;(epg-context-set-textmode context epa-textmode)
 981       (epg-context-set-textmode context t)
 982       (if sign
 983           (epg-context-set-signers context signers))
 984       (epg-context-set-passphrase-callback context
 985                                            #'epa-passphrase-callback-function)
 986       (epg-context-set-progress-callback context
 987                                          #'epa-progress-callback-function
 988                                          "Encrypting...")
 989       (message "Encrypting...")
 990       (setq cipher (epg-encrypt-string context
 991                                        (epa--encode-coding-string
 992                                         (buffer-substring start end)
 993                                         epa-last-coding-system-specified)
 994                                        recipients
 995                                        sign))
 996       (message "Encrypting...done")
 997       (delete-region start end)
 998       (goto-char start)
 999       (add-text-properties (point)
1000                            (progn
1001                              (insert cipher)
1002                              (point))
1003                            (list 'epa-coding-system-used
1004                                  epa-last-coding-system-specified
1005                                  'front-sticky nil
1006                                  'rear-nonsticky t
1007                                  'start-open t
1008                                  'end-open t)))))
1009
1010 ;;;###autoload
1011 (defun epa-delete-keys (keys &optional allow-secret)
1012   "Delete selected KEYS.
1013
1014 Don't use this command in Lisp programs!"
1015   (interactive
1016    (let ((keys (epa--marked-keys)))
1017      (unless keys
1018        (error "No keys selected"))
1019      (list keys
1020            (eq (nth 1 epa-list-keys-arguments) t))))
1021   (let ((context (epg-make-context epa-protocol)))
1022     (message "Deleting...")
1023     (epg-delete-keys context keys allow-secret)
1024     (message "Deleting...done")
1025     (apply #'epa-list-keys epa-list-keys-arguments)))
1026
1027 ;;;###autoload
1028 (defun epa-import-keys (file)
1029   "Import keys from FILE.
1030
1031 Don't use this command in Lisp programs!"
1032   (interactive "fFile: ")
1033   (setq file (expand-file-name file))
1034   (let ((context (epg-make-context epa-protocol)))
1035     (message "Importing %s..." (file-name-nondirectory file))
1036     (condition-case nil
1037         (progn
1038           (epg-import-keys-from-file context file)
1039           (message "Importing %s...done" (file-name-nondirectory file)))
1040       (error
1041        (message "Importing %s...failed" (file-name-nondirectory file))))
1042     (if (epg-context-result-for context 'import)
1043         (epa-display-info (epg-import-result-to-string
1044                            (epg-context-result-for context 'import))))
1045     (if (eq major-mode 'epa-key-list-mode)
1046         (apply #'epa-list-keys epa-list-keys-arguments))))
1047
1048 ;;;###autoload
1049 (defun epa-import-keys-region (start end)
1050   "Import keys from the region.
1051
1052 Don't use this command in Lisp programs!"
1053   (interactive "r")
1054   (let ((context (epg-make-context epa-protocol)))
1055     (message "Importing...")
1056     (condition-case nil
1057         (progn
1058           (epg-import-keys-from-string context (buffer-substring start end))
1059           (message "Importing...done"))
1060       (error
1061        (message "Importing...failed")))
1062     (if (epg-context-result-for context 'import)
1063         (epa-display-info (epg-import-result-to-string
1064                            (epg-context-result-for context 'import))))))
1065
1066 ;;;###autoload
1067 (defun epa-import-armor-in-region (start end)
1068   "Import keys in the OpenPGP armor format in the current region
1069 between START and END.
1070
1071 Don't use this command in Lisp programs!"
1072   (interactive "r")
1073   (save-excursion
1074     (save-restriction
1075       (narrow-to-region start end)
1076       (goto-char start)
1077       (let (armor-start armor-end)
1078         (while (re-search-forward
1079                 "-----BEGIN \\(PGP \\(PUBLIC\\|PRIVATE\\) KEY BLOCK\\)-----$"
1080                 nil t)
1081           (setq armor-start (match-beginning 0)
1082                 armor-end (re-search-forward
1083                            (concat "^-----END " (match-string 1) "-----$")
1084                            nil t))
1085           (unless armor-end
1086             (error "No armor tail"))
1087           (epa-import-keys-region armor-start armor-end))))))
1088
1089 ;;;###autoload
1090 (defun epa-export-keys (keys file)
1091   "Export selected KEYS to FILE.
1092
1093 Don't use this command in Lisp programs!"
1094   (interactive
1095    (let ((keys (epa--marked-keys))
1096          default-name)
1097      (unless keys
1098        (error "No keys selected"))
1099      (setq default-name
1100            (expand-file-name
1101             (concat (epg-sub-key-id (car (epg-key-sub-key-list (car keys))))
1102                     (if epa-armor ".asc" ".gpg"))
1103             default-directory))
1104      (list keys
1105            (expand-file-name
1106             (read-file-name
1107              (concat "To file (default "
1108                      (file-name-nondirectory default-name)
1109                      ") ")
1110              (file-name-directory default-name)
1111              default-name)))))
1112   (let ((context (epg-make-context epa-protocol)))
1113     (epg-context-set-armor context epa-armor)
1114     (message "Exporting to %s..." (file-name-nondirectory file))
1115     (epg-export-keys-to-file context keys file)
1116     (message "Exporting to %s...done" (file-name-nondirectory file))))
1117
1118 ;;;###autoload
1119 (defun epa-insert-keys (keys)
1120   "Insert selected KEYS after the point.
1121
1122 Don't use this command in Lisp programs!"
1123   (interactive
1124    (list (epa-select-keys (epg-make-context epa-protocol)
1125                           "Select keys to export.  ")))
1126   (let ((context (epg-make-context epa-protocol)))
1127     ;;(epg-context-set-armor context epa-armor)
1128     (epg-context-set-armor context t)
1129     (insert (epg-export-keys-to-string context keys))))
1130
1131 ;;;###autoload
1132 (defun epa-sign-keys (keys &optional local)
1133   "Sign selected KEYS.
1134 If a prefix-arg is specified, the signature is marked as non exportable.
1135
1136 Don't use this command in Lisp programs!"
1137   (interactive
1138    (let ((keys (epa--marked-keys)))
1139      (unless keys
1140        (error "No keys selected"))
1141      (list keys current-prefix-arg)))
1142   (let ((context (epg-make-context epa-protocol)))
1143     (epg-context-set-passphrase-callback context
1144                                          #'epa-passphrase-callback-function)
1145     (epg-context-set-progress-callback context
1146                                        #'epa-progress-callback-function
1147                                        "Signing keys...")
1148     (message "Signing keys...")
1149     (epg-sign-keys context keys local)
1150     (message "Signing keys...done")))
1151 (make-obsolete 'epa-sign-keys "Do not use.")
1152
1153 (provide 'epa)
1154
1155 ;;; epa.el ends here