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 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     (epg-context-set-progress-callback context
 824                                        #'epa-progress-callback-function
 825                                        "Verifying...")
 826     (epg-verify-string context
 827                        (epa--encode-coding-string
 828                         (buffer-substring start end)
 829                         (or coding-system-for-write
 830                             (get-text-property start
 831                                                'epa-coding-system-used))))
 832     (if (epg-context-result-for context 'verify)
 833         (epa-display-info (epg-verify-result-to-string
 834                            (epg-context-result-for context 'verify))))))
 835
 836 ;;;###autoload
 837 (defun epa-verify-cleartext-in-region (start end)
 838   "Verify OpenPGP cleartext signed messages in the current region
 839 between START and END.
 840
 841 Don't use this command in Lisp programs!"
 842   (interactive "r")
 843   (save-excursion
 844     (save-restriction
 845       (narrow-to-region start end)
 846       (goto-char start)
 847       (let (armor-start armor-end)
 848         (while (re-search-forward "-----BEGIN PGP SIGNED MESSAGE-----$"
 849                                   nil t)
 850           (setq armor-start (match-beginning 0))
 851           (unless (re-search-forward "^-----BEGIN PGP SIGNATURE-----$"
 852                                            nil t)
 853             (error "Invalid cleartext signed message"))
 854           (setq armor-end (re-search-forward
 855                            "^-----END PGP SIGNATURE-----$"
 856                            nil t))
 857           (unless armor-end
 858             (error "No armor tail"))
 859           (epa-verify-region armor-start armor-end))))))
 860
 861 (if (fboundp 'select-safe-coding-system)
 862     (defalias 'epa--select-safe-coding-system 'select-safe-coding-system)
 863   (defun epa--select-safe-coding-system (from to)
 864     buffer-file-coding-system))
 865
 866 ;;;###autoload
 867 (defun epa-sign-region (start end signers mode)
 868   "Sign the current region between START and END by SIGNERS keys selected.
 869
 870 Don't use this command in Lisp programs!"
 871   (interactive
 872    (let ((verbose current-prefix-arg))
 873      (setq epa-last-coding-system-specified
 874            (or coding-system-for-write
 875                (epa--select-safe-coding-system
 876                 (region-beginning) (region-end))))
 877      (list (region-beginning) (region-end)
 878            (if verbose
 879                (epa-select-keys (epg-make-context epa-protocol)
 880                                 "Select keys for signing.
 881 If no one is selected, default secret key is used.  "
 882                                 nil t))
 883            (if verbose
 884                (epa--read-signature-type)
 885              'clear))))
 886   (save-excursion
 887     (let ((context (epg-make-context epa-protocol))
 888           signature)
 889       ;;(epg-context-set-armor context epa-armor)
 890       (epg-context-set-armor context t)
 891       ;;(epg-context-set-textmode context epa-textmode)
 892       (epg-context-set-textmode context t)
 893       (epg-context-set-signers context signers)
 894       (epg-context-set-passphrase-callback context
 895                                            #'epa-passphrase-callback-function)
 896       (epg-context-set-progress-callback context
 897                                          #'epa-progress-callback-function
 898                                          "Signing...")
 899       (message "Signing...")
 900       (setq signature (epg-sign-string context
 901                                        (epa--encode-coding-string
 902                                         (buffer-substring start end)
 903                                         epa-last-coding-system-specified)
 904                                        mode))
 905       (message "Signing...done")
 906       (delete-region start end)
 907       (goto-char start)
 908       (add-text-properties (point)
 909                            (progn
 910                              (insert (epa--decode-coding-string
 911                                       signature
 912                                       (or coding-system-for-read
 913                                           epa-last-coding-system-specified)))
 914                              (point))
 915                            (list 'epa-coding-system-used
 916                                  epa-last-coding-system-specified
 917                                  'front-sticky nil
 918                                  'rear-nonsticky t
 919                                  'start-open t
 920                                  'end-open t)))))
 921
 922 (if (fboundp 'derived-mode-p)
 923     (defalias 'epa--derived-mode-p 'derived-mode-p)
 924   (defun epa--derived-mode-p (&rest modes)
 925     "Non-nil if the current major mode is derived from one of MODES.
 926 Uses the `derived-mode-parent' property of the symbol to trace backwards."
 927     (let ((parent major-mode))
 928       (while (and (not (memq parent modes))
 929                   (setq parent (get parent 'derived-mode-parent))))
 930       parent)))
 931
 932 ;;;###autoload
 933 (defun epa-encrypt-region (start end recipients sign signers)
 934   "Encrypt the current region between START and END for RECIPIENTS.
 935
 936 Don't use this command in Lisp programs!"
 937   (interactive
 938    (let ((verbose current-prefix-arg)
 939          (context (epg-make-context epa-protocol))
 940          sign)
 941      (setq epa-last-coding-system-specified
 942            (or coding-system-for-write
 943                (epa--select-safe-coding-system
 944                 (region-beginning) (region-end))))
 945      (list (region-beginning) (region-end)
 946            (epa-select-keys context
 947                             "Select recipients for encryption.
 948 If no one is selected, symmetric encryption will be performed.  ")
 949            (setq sign (if verbose (y-or-n-p "Sign? ")))
 950            (if sign
 951                (epa-select-keys context
 952                                 "Select keys for signing.  ")))))
 953   (save-excursion
 954     (let ((context (epg-make-context epa-protocol))
 955           cipher)
 956       ;;(epg-context-set-armor context epa-armor)
 957       (epg-context-set-armor context t)
 958       ;;(epg-context-set-textmode context epa-textmode)
 959       (epg-context-set-textmode context t)
 960       (if sign
 961           (epg-context-set-signers context signers))
 962       (epg-context-set-passphrase-callback context
 963                                            #'epa-passphrase-callback-function)
 964       (epg-context-set-progress-callback context
 965                                          #'epa-progress-callback-function
 966                                          "Encrypting...")
 967       (message "Encrypting...")
 968       (setq cipher (epg-encrypt-string context
 969                                        (epa--encode-coding-string
 970                                         (buffer-substring start end)
 971                                         epa-last-coding-system-specified)
 972                                        recipients
 973                                        sign))
 974       (message "Encrypting...done")
 975       (delete-region start end)
 976       (goto-char start)
 977       (add-text-properties (point)
 978                            (progn
 979                              (insert cipher)
 980                              (point))
 981                            (list 'epa-coding-system-used
 982                                  epa-last-coding-system-specified
 983                                  'front-sticky nil
 984                                  'rear-nonsticky t
 985                                  'start-open t
 986                                  'end-open t)))))
 987
 988 ;;;###autoload
 989 (defun epa-delete-keys (keys &optional allow-secret)
 990   "Delete selected KEYS.
 991
 992 Don't use this command in Lisp programs!"
 993   (interactive
 994    (let ((keys (epa--marked-keys)))
 995      (unless keys
 996        (error "No keys selected"))
 997      (list keys
 998            (eq (nth 1 epa-list-keys-arguments) t))))
 999   (let ((context (epg-make-context epa-protocol)))
1000     (message "Deleting...")
1001     (epg-delete-keys context keys allow-secret)
1002     (message "Deleting...done")
1003     (apply #'epa-list-keys epa-list-keys-arguments)))
1004
1005 ;;;###autoload
1006 (defun epa-import-keys (file)
1007   "Import keys from FILE.
1008
1009 Don't use this command in Lisp programs!"
1010   (interactive "fFile: ")
1011   (setq file (expand-file-name file))
1012   (let ((context (epg-make-context epa-protocol)))
1013     (message "Importing %s..." (file-name-nondirectory file))
1014     (condition-case nil
1015         (progn
1016           (epg-import-keys-from-file context file)
1017           (message "Importing %s...done" (file-name-nondirectory file)))
1018       (error
1019        (message "Importing %s...failed" (file-name-nondirectory file))))
1020     (if (epg-context-result-for context 'import)
1021         (epa-display-info (epg-import-result-to-string
1022                            (epg-context-result-for context 'import))))
1023     (if (eq major-mode 'epa-key-list-mode)
1024         (apply #'epa-list-keys epa-list-keys-arguments))))
1025
1026 ;;;###autoload
1027 (defun epa-import-keys-region (start end)
1028   "Import keys from the region.
1029
1030 Don't use this command in Lisp programs!"
1031   (interactive "r")
1032   (let ((context (epg-make-context epa-protocol)))
1033     (message "Importing...")
1034     (condition-case nil
1035         (progn
1036           (epg-import-keys-from-string context (buffer-substring start end))
1037           (message "Importing...done"))
1038       (error
1039        (message "Importing...failed")))
1040     (if (epg-context-result-for context 'import)
1041         (epa-display-info (epg-import-result-to-string
1042                            (epg-context-result-for context 'import))))))
1043
1044 ;;;###autoload
1045 (defun epa-import-armor-in-region (start end)
1046   "Import keys in the OpenPGP armor format in the current region
1047 between START and END.
1048
1049 Don't use this command in Lisp programs!"
1050   (interactive "r")
1051   (save-excursion
1052     (save-restriction
1053       (narrow-to-region start end)
1054       (goto-char start)
1055       (let (armor-start armor-end)
1056         (while (re-search-forward
1057                 "-----BEGIN \\(PGP \\(PUBLIC\\|PRIVATE\\) KEY BLOCK\\)-----$"
1058                 nil t)
1059           (setq armor-start (match-beginning 0)
1060                 armor-end (re-search-forward
1061                            (concat "^-----END " (match-string 1) "-----$")
1062                            nil t))
1063           (unless armor-end
1064             (error "No armor tail"))
1065           (epa-import-keys-region armor-start armor-end))))))
1066
1067 ;;;###autoload
1068 (defun epa-export-keys (keys file)
1069   "Export selected KEYS to FILE.
1070
1071 Don't use this command in Lisp programs!"
1072   (interactive
1073    (let ((keys (epa--marked-keys))
1074          default-name)
1075      (unless keys
1076        (error "No keys selected"))
1077      (setq default-name
1078            (expand-file-name
1079             (concat (epg-sub-key-id (car (epg-key-sub-key-list (car keys))))
1080                     (if epa-armor ".asc" ".gpg"))
1081             default-directory))
1082      (list keys
1083            (expand-file-name
1084             (read-file-name
1085              (concat "To file (default "
1086                      (file-name-nondirectory default-name)
1087                      ") ")
1088              (file-name-directory default-name)
1089              default-name)))))
1090   (let ((context (epg-make-context epa-protocol)))
1091     (epg-context-set-armor context epa-armor)
1092     (message "Exporting to %s..." (file-name-nondirectory file))
1093     (epg-export-keys-to-file context keys file)
1094     (message "Exporting to %s...done" (file-name-nondirectory file))))
1095
1096 ;;;###autoload
1097 (defun epa-insert-keys (keys)
1098   "Insert selected KEYS after the point.
1099
1100 Don't use this command in Lisp programs!"
1101   (interactive
1102    (list (epa-select-keys (epg-make-context epa-protocol)
1103                           "Select keys to export.  ")))
1104   (let ((context (epg-make-context epa-protocol)))
1105     ;;(epg-context-set-armor context epa-armor)
1106     (epg-context-set-armor context t)
1107     (insert (epg-export-keys-to-string context keys))))
1108
1109 ;;;###autoload
1110 (defun epa-sign-keys (keys &optional local)
1111   "Sign selected KEYS.
1112 If a prefix-arg is specified, the signature is marked as non exportable.
1113
1114 Don't use this command in Lisp programs!"
1115   (interactive
1116    (let ((keys (epa--marked-keys)))
1117      (unless keys
1118        (error "No keys selected"))
1119      (list keys current-prefix-arg)))
1120   (let ((context (epg-make-context epa-protocol)))
1121     (epg-context-set-passphrase-callback context
1122                                          #'epa-passphrase-callback-function)
1123     (epg-context-set-progress-callback context
1124                                        #'epa-progress-callback-function
1125                                        "Signing keys...")
1126     (message "Signing keys...")
1127     (epg-sign-keys context keys local)
1128     (message "Signing keys...done")))
1129 (make-obsolete 'epa-sign-keys "Do not use.")
1130
1131 (provide 'epa)
1132
1133 ;;; epa.el ends here