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