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