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