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