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