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
  31 (defgroup epa nil
  32   "The EasyPG Assistant"
  33   :group 'epg)
  34
  35 (defcustom epa-armor nil
  36   "If non-nil, epa commands create ASCII armored output."
  37   :type 'boolean
  38   :group 'epa)
  39
  40 (defcustom epa-textmode nil
  41   "If non-nil, epa commands treat input files as text."
  42   :type 'boolean
  43   :group 'epa)
  44
  45 (defgroup epa-faces nil
  46   "Faces for epa-mode."
  47   :group 'epa)
  48
  49 (defface epa-validity-high-face
  50   '((((class color) (background dark))
  51      (:foreground "PaleTurquoise" :bold t))
  52     (t
  53      (:bold t)))
  54   "Face used for displaying the high validity."
  55   :group 'epa-faces)
  56 (defvar epa-validity-high-face 'epa-validity-high-face)
  57
  58 (defface epa-validity-medium-face
  59   '((((class color) (background dark))
  60      (:foreground "PaleTurquoise" :italic t))
  61     (t
  62      ()))
  63   "Face used for displaying the medium validity."
  64   :group 'epa-faces)
  65 (defvar epa-validity-medium-face 'epa-validity-medium-face)
  66
  67 (defface epa-validity-low-face
  68   '((t
  69      (:italic t)))
  70   "Face used for displaying the low validity."
  71   :group 'epa-faces)
  72 (defvar epa-validity-low-face 'epa-validity-low-face)
  73
  74 (defface epa-validity-disabled-face
  75   '((t
  76      (:italic t :inverse-video t)))
  77   "Face used for displaying the disabled validity."
  78   :group 'epa-faces)
  79 (defvar epa-validity-disabled-face 'epa-validity-disabled-face)
  80
  81 (defface epa-string-face
  82   '((((class color)
  83       (background dark))
  84      (:foreground "lightyellow"))
  85     (((class color)
  86       (background light))
  87      (:foreground "blue4"))
  88     (t
  89      ()))
  90   "Face used for displaying the string."
  91   :group 'epa-faces)
  92 (defvar epa-string-face 'epa-string-face)
  93
  94 (defface epa-mark-face
  95   '((((class color) (background dark))
  96      (:foreground "orange" :bold t))
  97     (t
  98      (:foreground "red" :bold t)))
  99   "Face used for displaying the high validity."
 100   :group 'epa-faces)
 101 (defvar epa-mark-face 'epa-mark-face)
 102
 103 (defface epa-field-name-face
 104   '((((class color) (background dark))
 105      (:foreground "PaleTurquoise" :bold t))
 106     (t (:bold t)))
 107   "Face for the name of the attribute field."
 108   :group 'epa)
 109 (defvar epa-field-name-face 'epa-field-name-face)
 110
 111 (defface epa-field-body-face
 112   '((((class color) (background dark))
 113      (:foreground "turquoise" :italic t))
 114     (t (:italic t)))
 115   "Face for the body of the attribute field."
 116   :group 'epa)
 117 (defvar epa-field-body-face 'epa-field-body-face)
 118
 119 (defcustom epa-validity-face-alist
 120   '((unknown . epa-validity-disabled-face)
 121     (invalid . epa-validity-disabled-face)
 122     (disabled . epa-validity-disabled-face)
 123     (revoked . epa-validity-disabled-face)
 124     (expired . epa-validity-disabled-face)
 125     (none . epa-validity-low-face)
 126     (undefined . epa-validity-low-face)
 127     (never . epa-validity-low-face)
 128     (marginal . epa-validity-medium-face)
 129     (full . epa-validity-high-face)
 130     (ultimate . epa-validity-high-face))
 131   "An alist mapping validity values to faces."
 132   :type 'list
 133   :group 'epa)
 134
 135 (defcustom epa-font-lock-keywords
 136   '(("^\\*"
 137      (0 epa-mark-face))
 138     ("^\t\\([^\t:]+:\\)[ \t]*\\(.*\\)$"
 139      (1 epa-field-name-face)
 140      (2 epa-field-body-face)))
 141   "Default expressions to addon in epa-mode."
 142   :type '(repeat (list string))
 143   :group 'epa)
 144
 145 (defconst epa-pubkey-algorithm-letter-alist
 146   '((1 . ?R)
 147     (2 . ?r)
 148     (3 . ?s)
 149     (16 . ?g)
 150     (17 . ?D)
 151     (20 . ?G)))
 152
 153 (defvar epa-keys-buffer nil)
 154 (defvar epa-key-buffer-alist nil)
 155 (defvar epa-key nil)
 156 (defvar epa-list-keys-arguments nil)
 157
 158 (defvar epa-keys-mode-map
 159   (let ((keymap (make-sparse-keymap)))
 160     (define-key keymap "m" 'epa-mark)
 161     (define-key keymap "u" 'epa-unmark)
 162     (define-key keymap "d" 'epa-decrypt-file)
 163     (define-key keymap "v" 'epa-verify-file)
 164     (define-key keymap "s" 'epa-sign-file)
 165     (define-key keymap "S" 'epa-sign-keys)
 166     (define-key keymap "e" 'epa-encrypt-file)
 167     (define-key keymap "r" 'epa-delete-keys)
 168     (define-key keymap "i" 'epa-import-keys)
 169     (define-key keymap "o" 'epa-export-keys)
 170     (define-key keymap "g" 'epa-list-keys)
 171     (define-key keymap "n" 'next-line)
 172     (define-key keymap "p" 'previous-line)
 173     (define-key keymap " " 'scroll-up)
 174     (define-key keymap [delete] 'scroll-down)
 175     (define-key keymap "q" 'epa-exit-buffer)
 176     keymap))
 177
 178 (defvar epa-exit-buffer-function #'bury-buffer)
 179
 180 (define-widget 'epa-key 'push-button
 181   "Button for representing a epg-key object."
 182   :format "%[%v%]"
 183   :button-face-get 'epa-key-widget-button-face-get
 184   :value-create 'epa-key-widget-value-create
 185   :action 'epa-key-widget-action
 186   :help-echo 'epa-key-widget-help-echo)
 187
 188 (defun epa-key-widget-action (widget &optional event)
 189   (epa-show-key (widget-get widget :value)))
 190
 191 (defun epa-key-widget-value-create (widget)
 192   (let* ((key (widget-get widget :value))
 193          (primary-sub-key (car (epg-key-sub-key-list key)))
 194          (primary-user-id (car (epg-key-user-id-list key))))
 195     (insert (format "%c "
 196                     (if (epg-sub-key-validity primary-sub-key)
 197                         (car (rassq (epg-sub-key-validity primary-sub-key)
 198                                     epg-key-validity-alist))
 199                       ? ))
 200             (epg-sub-key-id primary-sub-key)
 201             " "
 202             (if (stringp (epg-user-id-string primary-user-id))
 203                 (epg-user-id-string primary-user-id)
 204               (epg-decode-dn (epg-user-id-string primary-user-id))))))
 205
 206 (defun epa-key-widget-button-face-get (widget)
 207   (let ((validity (epg-sub-key-validity (car (epg-key-sub-key-list
 208                                               (widget-get widget :value))))))
 209     (if validity
 210         (cdr (assq validity epa-validity-face-alist))
 211       'default)))
 212
 213 (defun epa-key-widget-help-echo (widget)
 214   (format "Show %s"
 215           (epg-sub-key-id (car (epg-key-sub-key-list
 216                                 (widget-get widget :value))))))
 217
 218 (defun epa-keys-mode ()
 219   "Major mode for `epa-list-keys'."
 220   (kill-all-local-variables)
 221   (buffer-disable-undo)
 222   (setq major-mode 'epa-keys-mode
 223         mode-name "Keys"
 224         truncate-lines t
 225         buffer-read-only t)
 226   (use-local-map epa-keys-mode-map)
 227   (set-keymap-parent (current-local-map) widget-keymap)
 228   (make-local-variable 'font-lock-defaults)
 229   (setq font-lock-defaults '(epa-font-lock-keywords t))
 230   ;; In XEmacs, auto-initialization of font-lock is not effective
 231   ;; if buffer-file-name is not set.
 232   (font-lock-set-defaults)
 233   (widget-setup)
 234   (make-local-variable 'epa-exit-buffer-function)
 235   (run-hooks 'epa-keys-mode-hook))
 236
 237 (defvar epa-key-mode-map
 238   (let ((keymap (make-sparse-keymap)))
 239     (define-key keymap "q" 'bury-buffer)
 240     keymap))
 241
 242 (defun epa-key-mode ()
 243   "Major mode for `epa-show-key'."
 244   (kill-all-local-variables)
 245   (buffer-disable-undo)
 246   (setq major-mode 'epa-key-mode
 247         mode-name "Key"
 248         truncate-lines t
 249         buffer-read-only t)
 250   (use-local-map epa-key-mode-map)
 251   (make-local-variable 'font-lock-defaults)
 252   (setq font-lock-defaults '(epa-font-lock-keywords t))
 253   ;; In XEmacs, auto-initialization of font-lock is not effective
 254   ;; if buffer-file-name is not set.
 255   (font-lock-set-defaults)
 256   (make-local-variable 'epa-exit-buffer-function)
 257   (run-hooks 'epa-key-mode-hook))
 258
 259 ;;;###autoload
 260 (defun epa-list-keys (&optional name mode protocol)
 261   (interactive
 262    (if current-prefix-arg
 263        (let ((name (read-string "Pattern: "
 264                                 (if epa-list-keys-arguments
 265                                     (car epa-list-keys-arguments)))))
 266          (list (if (equal name "") nil name)
 267                (y-or-n-p "Secret keys? ")
 268                (intern (completing-read "Protocol? "
 269                                         '(("OpenPGP") ("CMS"))
 270                                         nil t))))
 271      (or epa-list-keys-arguments (list nil nil nil))))
 272   (unless (and epa-keys-buffer
 273                (buffer-live-p epa-keys-buffer))
 274     (setq epa-keys-buffer (generate-new-buffer "*Keys*")))
 275   (set-buffer epa-keys-buffer)
 276   (let ((inhibit-read-only t)
 277         buffer-read-only
 278         (point (point-min))
 279         (context (epg-make-context protocol)))
 280     (unless (get-text-property point 'epa-list-keys)
 281       (setq point (next-single-property-change point 'epa-list-keys)))
 282     (when point
 283       (delete-region point
 284                      (or (next-single-property-change point 'epa-list-keys)
 285                          (point-max)))
 286       (goto-char point))
 287     (epa-insert-keys context name mode)
 288     (epa-keys-mode))
 289   (make-local-variable 'epa-list-keys-arguments)
 290   (setq epa-list-keys-arguments (list name mode protocol))
 291   (goto-char (point-min))
 292   (pop-to-buffer (current-buffer)))
 293
 294 (defun epa-insert-keys (context name mode)
 295   (save-excursion
 296     (save-restriction
 297       (narrow-to-region (point) (point))
 298       (let ((keys (epg-list-keys context name mode))
 299             point)
 300         (while keys
 301           (setq point (point))
 302           (insert "  ")
 303           (put-text-property point (point) 'epa-key (car keys))
 304           (widget-create 'epa-key :value (car keys))
 305           (insert "\n")
 306           (setq keys (cdr keys))))
 307       (put-text-property (point-min) (point-max) 'epa-list-keys t))))
 308
 309 (defun epa-marked-keys ()
 310   (or (save-excursion
 311         (set-buffer epa-keys-buffer)
 312         (goto-char (point-min))
 313         (let (keys key)
 314           (while (re-search-forward "^\\*" nil t)
 315             (if (setq key (get-text-property (match-beginning 0)
 316                                              'epa-key))
 317                 (setq keys (cons key keys))))
 318           (nreverse keys)))
 319       (save-excursion
 320         (beginning-of-line)
 321         (let ((key (get-text-property (point) 'epa-key)))
 322           (if key
 323               (list key))))))
 324
 325 ;;;###autoload
 326 (defun epa-select-keys (context prompt &optional names secret)
 327   "Display a user's keyring and ask him to select keys.
 328 CONTEXT is an epg-context.
 329 PROMPT is a string to prompt with.
 330 NAMES is a list of strings to be matched with keys.  If it is nil, all
 331 the keys are listed.
 332 If SECRET is non-nil, list secret keys instead of public keys."
 333   (save-excursion
 334     (unless (and epa-keys-buffer
 335                  (buffer-live-p epa-keys-buffer))
 336       (setq epa-keys-buffer (generate-new-buffer "*Keys*")))
 337     (let ((inhibit-read-only t)
 338           buffer-read-only
 339           point)
 340       (set-buffer epa-keys-buffer)
 341       (erase-buffer)
 342       (insert prompt "\n")
 343       (widget-create 'link
 344                      :notify (lambda (&rest ignore) (abort-recursive-edit))
 345                      :help-echo
 346                      (substitute-command-keys
 347                       "Click here or \\[abort-recursive-edit] to cancel")
 348                      "Cancel")
 349       (widget-create 'link
 350                      :notify (lambda (&rest ignore) (exit-recursive-edit))
 351                      :help-echo
 352                      (substitute-command-keys
 353                       "Click here or \\[exit-recursive-edit] to finish")
 354                      "OK")
 355       (insert "\n\n")
 356       (if names
 357           (while names
 358             (setq point (point))
 359             (epa-insert-keys context (car names) secret)
 360             (goto-char point)
 361             (epa-mark)
 362             (goto-char (point-max))
 363             (setq names (cdr names)))
 364         (epa-insert-keys context nil secret))
 365       (epa-keys-mode)
 366       (setq epa-exit-buffer-function #'abort-recursive-edit)
 367       (goto-char (point-min))
 368       (pop-to-buffer (current-buffer)))
 369     (unwind-protect
 370           (progn
 371             (recursive-edit)
 372             (epa-marked-keys))
 373         (if (get-buffer-window epa-keys-buffer)
 374             (delete-window (get-buffer-window epa-keys-buffer)))
 375         (kill-buffer epa-keys-buffer))))
 376
 377 (defun epa-show-key (key)
 378   (let* ((primary-sub-key (car (epg-key-sub-key-list key)))
 379          (entry (assoc (epg-sub-key-id primary-sub-key)
 380                        epa-key-buffer-alist))
 381          (inhibit-read-only t)
 382          buffer-read-only
 383          pointer)
 384     (unless entry
 385       (setq entry (cons (epg-sub-key-id primary-sub-key) nil)
 386             epa-key-buffer-alist (cons entry epa-key-buffer-alist)))
 387     (unless (and (cdr entry)
 388                  (buffer-live-p (cdr entry)))
 389       (setcdr entry (generate-new-buffer
 390                      (format "*Key*%s" (epg-sub-key-id primary-sub-key)))))
 391     (set-buffer (cdr entry))
 392     (make-local-variable 'epa-key)
 393     (setq epa-key key)
 394     (erase-buffer)
 395     (setq pointer (epg-key-user-id-list key))
 396     (while pointer
 397       (insert " "
 398               (if (epg-user-id-validity (car pointer))
 399                   (char-to-string
 400                    (car (rassq (epg-user-id-validity (car pointer))
 401                                epg-key-validity-alist)))
 402                 " ")
 403               " "
 404               (if (stringp (epg-user-id-string (car pointer)))
 405                   (epg-user-id-string (car pointer))
 406                 (epg-decode-dn (epg-user-id-string (car pointer))))
 407               "\n")
 408       (setq pointer (cdr pointer)))
 409     (setq pointer (epg-key-sub-key-list key))
 410     (while pointer
 411       (insert " "
 412               (if (epg-sub-key-validity (car pointer))
 413                   (char-to-string
 414                    (car (rassq (epg-sub-key-validity (car pointer))
 415                                epg-key-validity-alist)))
 416                 " ")
 417               " "
 418               (epg-sub-key-id (car pointer))
 419               " "
 420               (format "%dbits"
 421                       (epg-sub-key-length (car pointer)))
 422               " "
 423               (cdr (assq (epg-sub-key-algorithm (car pointer))
 424                          epg-pubkey-algorithm-alist))
 425               "\n\tCreated: "
 426               (epg-sub-key-creation-time (car pointer))
 427               (if (epg-sub-key-expiration-time (car pointer))
 428                   (format "\n\tExpires: %s" (epg-sub-key-expiration-time
 429                                              (car pointer)))
 430                 "")
 431               "\n\tCapabilities: "
 432               (mapconcat #'symbol-name
 433                          (epg-sub-key-capability (car pointer))
 434                          " ")
 435               "\n\tFingerprint: "
 436               (epg-sub-key-fingerprint (car pointer))
 437               "\n")
 438       (setq pointer (cdr pointer)))
 439     (goto-char (point-min))
 440     (pop-to-buffer (current-buffer))
 441     (epa-key-mode)))
 442
 443 (defun epa-show-key-notify (widget &rest ignore)
 444   (epa-show-key (widget-get widget :value)))
 445
 446 (defun epa-mark (&optional arg)
 447   "Mark the current line.
 448 If ARG is non-nil, unmark the current line."
 449   (interactive "P")
 450   (let ((inhibit-read-only t)
 451         buffer-read-only
 452         properties)
 453     (beginning-of-line)
 454     (setq properties (text-properties-at (point)))
 455     (delete-char 1)
 456     (insert (if arg " " "*"))
 457     (set-text-properties (1- (point)) (point) properties)
 458     (forward-line)))
 459
 460 (defun epa-unmark (&optional arg)
 461   "Unmark the current line.
 462 If ARG is non-nil, mark the current line."
 463   (interactive "P")
 464   (epa-mark (not arg)))
 465
 466 (defun epa-exit-buffer ()
 467   "Exit the current buffer.
 468 `epa-exit-buffer-function' is called if it is set."
 469   (interactive)
 470   (funcall epa-exit-buffer-function))
 471
 472 ;;;###autoload
 473 (defun epa-decrypt-file (file)
 474   "Decrypt FILE."
 475   (interactive "fFile: ")
 476   (let* ((default-name (file-name-sans-extension file))
 477          (plain (expand-file-name
 478                  (read-file-name
 479                   (concat "To file (default "
 480                           (file-name-nondirectory default-name)
 481                           ") ")
 482                   (file-name-directory default-name)
 483                   default-name)))
 484          (context (epg-make-context)))
 485     (message "Decrypting %s..." (file-name-nondirectory file))
 486     (epg-decrypt-file context file plain)
 487     (message "Decrypting %s...done" (file-name-nondirectory file))
 488     (if (epg-context-result-for context 'verify)
 489         (message "%s"
 490                  (epg-verify-result-to-string
 491                   (epg-context-result-for context 'verify))))))
 492
 493 ;;;###autoload
 494 (defun epa-verify-file (file)
 495   "Verify FILE."
 496   (interactive "fFile: ")
 497   (let* ((context (epg-make-context))
 498          (plain (if (equal (file-name-extension file) "sig")
 499                     (file-name-sans-extension file))))
 500     (message "Verifying %s..." (file-name-nondirectory file))
 501     (epg-verify-file context file plain)
 502     (message "Verifying %s...done" (file-name-nondirectory file))
 503     (message "%s"
 504              (epg-verify-result-to-string
 505               (epg-context-result-for context 'verify)))))
 506
 507 ;;;###autoload
 508 (defun epa-sign-file (file signers mode)
 509   "Sign FILE by SIGNERS keys selected."
 510   (interactive
 511    (list (expand-file-name (read-file-name "File: "))
 512          (epa-select-keys (epg-make-context) "Select keys for signing.
 513 If no one is selected, default secret key is used.  "
 514                           nil t)
 515          (if (y-or-n-p "Make a detached signature? ")
 516              'detached
 517            (if (y-or-n-p "Make a cleartext signature? ")
 518                'clear))))
 519   (let ((signature (concat file
 520                            (if (or epa-armor
 521                                    (not (memq mode '(nil t normal detached))))
 522                                ".asc"
 523                              (if (memq mode '(t detached))
 524                                  ".sig"
 525                                ".gpg"))))
 526         (context (epg-make-context)))
 527     (epg-context-set-armor context epa-armor)
 528     (epg-context-set-textmode context epa-textmode)
 529     (epg-context-set-signers context signers)
 530     (message "Signing %s..." (file-name-nondirectory file))
 531     (epg-sign-file context file signature mode)
 532     (message "Signing %s...done" (file-name-nondirectory file))))
 533
 534 ;;;###autoload
 535 (defun epa-encrypt-file (file recipients)
 536   "Encrypt FILE for RECIPIENTS."
 537   (interactive
 538    (list (expand-file-name (read-file-name "File: "))
 539          (epa-select-keys (epg-make-context) "Select recipents for encryption.
 540 If no one is selected, symmetric encryption will be performed.  ")))
 541   (let ((cipher (concat file (if epa-armor ".asc" ".gpg")))
 542         (context (epg-make-context)))
 543     (epg-context-set-armor context epa-armor)
 544     (epg-context-set-textmode context epa-textmode)
 545     (message "Encrypting %s..." (file-name-nondirectory file))
 546     (epg-encrypt-file context file recipients cipher)
 547     (message "Encrypting %s...done" (file-name-nondirectory file))))
 548
 549 ;;;###autoload
 550 (defun epa-decrypt-region (start end)
 551   "Decrypt the current region between START and END.
 552
 553 Don't use this command in Lisp programs!"
 554   (interactive "r")
 555   (save-excursion
 556     (let ((context (epg-make-context))
 557           plain)
 558       (message "Decrypting...")
 559       (setq plain (epg-decrypt-string context (buffer-substring start end)))
 560       (message "Decrypting...done")
 561       (delete-region start end)
 562       (goto-char start)
 563       (insert (decode-coding-string plain coding-system-for-read))
 564       (if (epg-context-result-for context 'verify)
 565           (message "%s"
 566                    (epg-verify-result-to-string
 567                     (epg-context-result-for context 'verify)))))))
 568
 569 ;;;###autoload
 570 (defun epa-decrypt-armor-in-region (start end)
 571   "Decrypt OpenPGP armors in the current region between START and END.
 572
 573 Don't use this command in Lisp programs!"
 574   (interactive "r")
 575   (save-excursion
 576     (save-restriction
 577       (narrow-to-region start end)
 578       (goto-char start)
 579       (let (armor-start armor-end charset coding-system)
 580         (while (re-search-forward "-----BEGIN PGP MESSAGE-----$" nil t)
 581           (setq armor-start (match-beginning 0)
 582                 armor-end (re-search-forward "^-----END PGP MESSAGE-----$"
 583                                              nil t))
 584           (unless armor-end
 585             (error "No armor tail"))
 586           (goto-char armor-start)
 587           (if (re-search-forward "^Charset: \\(.*\\)" armor-end t)
 588               (setq charset (match-string 1)))
 589           (if coding-system-for-read
 590               (setq coding-system coding-system-for-read)
 591             (if charset
 592                 (setq coding-system (intern (downcase charset)))
 593               (setq coding-system 'utf-8)))
 594           (let ((coding-system-for-read coding-system))
 595             (epa-decrypt-region start end)))))))
 596
 597 ;;;###autoload
 598 (defun epa-verify-region (start end)
 599   "Verify the current region between START and END.
 600
 601 Don't use this command in Lisp programs!"
 602   (interactive "r")
 603   (let ((context (epg-make-context)))
 604     (epg-verify-string context
 605                        (encode-coding-string
 606                         (buffer-substring start end)
 607                         coding-system-for-write))
 608     (message "%s"
 609              (epg-verify-result-to-string
 610               (epg-context-result-for context 'verify)))))
 611
 612 ;;;###autoload
 613 (defun epa-verify-armor-in-region (start end)
 614   "Verify OpenPGP armors in the current region between START and END.
 615
 616 Don't use this command in Lisp programs!"
 617   (interactive "r")
 618   (save-excursion
 619     (save-restriction
 620       (narrow-to-region start end)
 621       (goto-char start)
 622       (let (armor-start armor-end)
 623         (while (re-search-forward "-----BEGIN PGP\\( SIGNED\\)? MESSAGE-----$"
 624                                   nil t)
 625           (setq armor-start (match-beginning 0))
 626           (if (match-beginning 1)       ;cleartext signed message
 627               (progn
 628                 (unless (re-search-forward "^-----BEGIN PGP SIGNATURE-----$"
 629                                            nil t)
 630                   (error "Invalid cleartext signed message"))
 631                 (setq armor-end (re-search-forward
 632                                  "^-----END PGP SIGNATURE-----$"
 633                                  nil t)))
 634             (setq armor-end (re-search-forward
 635                              "^-----END PGP MESSAGE-----$"
 636                              nil t)))
 637           (unless armor-end
 638             (error "No armor tail"))
 639           (epa-verify-region armor-start armor-end))))))
 640
 641 ;;;###autoload
 642 (defun epa-sign-region (start end signers mode)
 643   "Sign the current region between START and END by SIGNERS keys selected.
 644
 645 Don't use this command in Lisp programs!"
 646   (interactive
 647    (list (region-beginning) (region-end)
 648          (epa-select-keys (epg-make-context) "Select keys for signing.
 649 If no one is selected, default secret key is used.  "
 650                           nil t)
 651          (if (y-or-n-p "Make a detached signature? ")
 652              'detached
 653            (if (y-or-n-p "Make a cleartext signature? ")
 654                'clear))))
 655   (save-excursion
 656     (let ((context (epg-make-context))
 657           signature)
 658       (epg-context-set-armor context epa-armor)
 659       (epg-context-set-textmode context epa-textmode)
 660       (epg-context-set-signers context signers)
 661       (message "Signing...")
 662       (setq signature (epg-sign-string context
 663                                        (encode-coding-string
 664                                         (buffer-substring start end)
 665                                         coding-system-for-write)
 666                                        mode))
 667       (message "Signing...done")
 668       (delete-region start end)
 669       (insert (decode-coding-string signature coding-system-for-read)))))
 670
 671 ;;;###autoload
 672 (defun epa-encrypt-region (start end recipients)
 673   "Encrypt the current region between START and END for RECIPIENTS.
 674
 675 Don't use this command in Lisp programs!"
 676   (interactive
 677    (list (region-beginning) (region-end)
 678          (epa-select-keys (epg-make-context) "Select recipents for encryption.
 679 If no one is selected, symmetric encryption will be performed.  ")))
 680   (save-excursion
 681     (let ((context (epg-make-context))
 682           cipher)
 683       (epg-context-set-armor context epa-armor)
 684       (epg-context-set-textmode context epa-textmode)
 685       (message "Encrypting...")
 686       (setq cipher (epg-encrypt-string context
 687                                        (encode-coding-string
 688                                         (buffer-substring start end)
 689                                         coding-system-for-write)
 690                                        recipients))
 691       (message "Encrypting...done")
 692       (delete-region start end)
 693       (insert cipher))))
 694
 695 ;;;###autoload
 696 (defun epa-delete-keys (keys &optional allow-secret)
 697   "Delete selected KEYS."
 698   (interactive
 699    (let ((keys (epa-marked-keys)))
 700      (unless keys
 701        (error "No keys selected"))
 702      (list keys
 703            (eq (nth 1 epa-list-keys-arguments) t))))
 704   (let ((context (epg-make-context)))
 705     (message "Deleting...")
 706     (epg-delete-keys context keys allow-secret)
 707     (message "Deleting...done")
 708     (apply #'epa-list-keys epa-list-keys-arguments)))
 709
 710 ;;;###autoload
 711 (defun epa-import-keys (file)
 712   "Import keys from FILE."
 713   (interactive "fFile: ")
 714   (let ((context (epg-make-context)))
 715     (message "Importing %s..." (file-name-nondirectory file))
 716     (epg-import-keys-from-file context (expand-file-name file))
 717     (message "Importing %s...done" (file-name-nondirectory file))
 718     (apply #'epa-list-keys epa-list-keys-arguments)))
 719
 720 ;;;###autoload
 721 (defun epa-export-keys (keys file)
 722   "Export selected KEYS to FILE."
 723   (interactive
 724    (let ((keys (epa-marked-keys))
 725          default-name)
 726      (unless keys
 727        (error "No keys selected"))
 728      (setq default-name
 729            (expand-file-name
 730             (concat (epg-sub-key-id (car (epg-key-sub-key-list (car keys))))
 731                     (if epa-armor ".asc" ".gpg"))
 732             default-directory))
 733      (list keys
 734            (expand-file-name
 735             (read-file-name
 736              (concat "To file (default "
 737                      (file-name-nondirectory default-name)
 738                      ") ")
 739              (file-name-directory default-name)
 740              default-name)))))
 741   (let ((context (epg-make-context)))
 742     (epg-context-set-armor context epa-armor)
 743     (message "Exporting to %s..." (file-name-nondirectory file))
 744     (epg-export-keys-to-file context keys file)
 745     (message "Exporting to %s...done" (file-name-nondirectory file))))
 746
 747 ;;;###autoload
 748 (defun epa-sign-keys (keys &optional local)
 749   "Sign selected KEYS.
 750 If LOCAL is non-nil, the signature is marked as non exportable."
 751   (interactive
 752    (let ((keys (epa-marked-keys)))
 753      (unless keys
 754        (error "No keys selected"))
 755      (list keys current-prefix-arg)))
 756   (let ((context (epg-make-context)))
 757     (message "Signing keys...")
 758     (epg-sign-keys context keys local)
 759     (message "Signing keys...done")))
 760
 761 (provide 'epa)
 762
 763 ;;; epa.el ends here