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--list-keys-1 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--list-keys-1 (context name mode)
 295   (save-restriction
 296     (narrow-to-region (point) (point))
 297     (let ((inhibit-read-only t)
 298           buffer-read-only
 299           (keys (epg-list-keys context name mode))
 300           point)
 301       (while keys
 302         (setq point (point))
 303         (insert "  ")
 304         (put-text-property point (point) 'epa-key (car keys))
 305         (widget-create 'epa-key :value (car keys))
 306         (insert "\n")
 307         (setq keys (cdr keys))))
 308     (put-text-property (point-min) (point-max) 'epa-list-keys t)))
 309
 310 (defun epa-marked-keys ()
 311   (or (save-excursion
 312         (set-buffer epa-keys-buffer)
 313         (goto-char (point-min))
 314         (let (keys key)
 315           (while (re-search-forward "^\\*" nil t)
 316             (if (setq key (get-text-property (match-beginning 0)
 317                                              'epa-key))
 318                 (setq keys (cons key keys))))
 319           (nreverse keys)))
 320       (save-excursion
 321         (beginning-of-line)
 322         (let ((key (get-text-property (point) 'epa-key)))
 323           (if key
 324               (list key))))))
 325
 326 ;;;###autoload
 327 (defun epa-select-keys (context prompt &optional names secret)
 328   "Display a user's keyring and ask him to select keys.
 329 CONTEXT is an epg-context.
 330 PROMPT is a string to prompt with.
 331 NAMES is a list of strings to be matched with keys.  If it is nil, all
 332 the keys are listed.
 333 If SECRET is non-nil, list secret keys instead of public keys."
 334   (save-excursion
 335     (unless (and epa-keys-buffer
 336                  (buffer-live-p epa-keys-buffer))
 337       (setq epa-keys-buffer (generate-new-buffer "*Keys*")))
 338     (let ((inhibit-read-only t)
 339           buffer-read-only
 340           point)
 341       (set-buffer epa-keys-buffer)
 342       (erase-buffer)
 343       (insert prompt "\n")
 344       (widget-create 'link
 345                      :notify (lambda (&rest ignore) (abort-recursive-edit))
 346                      :help-echo
 347                      (substitute-command-keys
 348                       "Click here or \\[abort-recursive-edit] to cancel")
 349                      "Cancel")
 350       (widget-create 'link
 351                      :notify (lambda (&rest ignore) (exit-recursive-edit))
 352                      :help-echo
 353                      (substitute-command-keys
 354                       "Click here or \\[exit-recursive-edit] to finish")
 355                      "OK")
 356       (insert "\n\n")
 357       (if names
 358           (while names
 359             (setq point (point))
 360             (epa--list-keys-1 context (car names) secret)
 361             (goto-char point)
 362             (epa-mark)
 363             (goto-char (point-max))
 364             (setq names (cdr names)))
 365         (epa--list-keys-1 context nil secret))
 366       (epa-keys-mode)
 367       (setq epa-exit-buffer-function #'abort-recursive-edit)
 368       (goto-char (point-min))
 369       (pop-to-buffer (current-buffer)))
 370     (unwind-protect
 371           (progn
 372             (recursive-edit)
 373             (epa-marked-keys))
 374         (if (get-buffer-window epa-keys-buffer)
 375             (delete-window (get-buffer-window epa-keys-buffer)))
 376         (kill-buffer epa-keys-buffer))))
 377
 378 (defun epa-show-key (key)
 379   (let* ((primary-sub-key (car (epg-key-sub-key-list key)))
 380          (entry (assoc (epg-sub-key-id primary-sub-key)
 381                        epa-key-buffer-alist))
 382          (inhibit-read-only t)
 383          buffer-read-only
 384          pointer)
 385     (unless entry
 386       (setq entry (cons (epg-sub-key-id primary-sub-key) nil)
 387             epa-key-buffer-alist (cons entry epa-key-buffer-alist)))
 388     (unless (and (cdr entry)
 389                  (buffer-live-p (cdr entry)))
 390       (setcdr entry (generate-new-buffer
 391                      (format "*Key*%s" (epg-sub-key-id primary-sub-key)))))
 392     (set-buffer (cdr entry))
 393     (make-local-variable 'epa-key)
 394     (setq epa-key key)
 395     (erase-buffer)
 396     (setq pointer (epg-key-user-id-list key))
 397     (while pointer
 398       (insert " "
 399               (if (epg-user-id-validity (car pointer))
 400                   (char-to-string
 401                    (car (rassq (epg-user-id-validity (car pointer))
 402                                epg-key-validity-alist)))
 403                 " ")
 404               " "
 405               (if (stringp (epg-user-id-string (car pointer)))
 406                   (epg-user-id-string (car pointer))
 407                 (epg-decode-dn (epg-user-id-string (car pointer))))
 408               "\n")
 409       (setq pointer (cdr pointer)))
 410     (setq pointer (epg-key-sub-key-list key))
 411     (while pointer
 412       (insert " "
 413               (if (epg-sub-key-validity (car pointer))
 414                   (char-to-string
 415                    (car (rassq (epg-sub-key-validity (car pointer))
 416                                epg-key-validity-alist)))
 417                 " ")
 418               " "
 419               (epg-sub-key-id (car pointer))
 420               " "
 421               (format "%dbits"
 422                       (epg-sub-key-length (car pointer)))
 423               " "
 424               (cdr (assq (epg-sub-key-algorithm (car pointer))
 425                          epg-pubkey-algorithm-alist))
 426               "\n\tCreated: "
 427               (epg-sub-key-creation-time (car pointer))
 428               (if (epg-sub-key-expiration-time (car pointer))
 429                   (format "\n\tExpires: %s" (epg-sub-key-expiration-time
 430                                              (car pointer)))
 431                 "")
 432               "\n\tCapabilities: "
 433               (mapconcat #'symbol-name
 434                          (epg-sub-key-capability (car pointer))
 435                          " ")
 436               "\n\tFingerprint: "
 437               (epg-sub-key-fingerprint (car pointer))
 438               "\n")
 439       (setq pointer (cdr pointer)))
 440     (goto-char (point-min))
 441     (pop-to-buffer (current-buffer))
 442     (epa-key-mode)))
 443
 444 (defun epa-show-key-notify (widget &rest ignore)
 445   (epa-show-key (widget-get widget :value)))
 446
 447 (defun epa-mark (&optional arg)
 448   "Mark the current line.
 449 If ARG is non-nil, unmark the current line."
 450   (interactive "P")
 451   (let ((inhibit-read-only t)
 452         buffer-read-only
 453         properties)
 454     (beginning-of-line)
 455     (setq properties (text-properties-at (point)))
 456     (delete-char 1)
 457     (insert (if arg " " "*"))
 458     (set-text-properties (1- (point)) (point) properties)
 459     (forward-line)))
 460
 461 (defun epa-unmark (&optional arg)
 462   "Unmark the current line.
 463 If ARG is non-nil, mark the current line."
 464   (interactive "P")
 465   (epa-mark (not arg)))
 466
 467 (defun epa-exit-buffer ()
 468   "Exit the current buffer.
 469 `epa-exit-buffer-function' is called if it is set."
 470   (interactive)
 471   (funcall epa-exit-buffer-function))
 472
 473 ;;;###autoload
 474 (defun epa-decrypt-file (file)
 475   "Decrypt FILE."
 476   (interactive "fFile: ")
 477   (let* ((default-name (file-name-sans-extension file))
 478          (plain (expand-file-name
 479                  (read-file-name
 480                   (concat "To file (default "
 481                           (file-name-nondirectory default-name)
 482                           ") ")
 483                   (file-name-directory default-name)
 484                   default-name)))
 485          (context (epg-make-context)))
 486     (message "Decrypting %s..." (file-name-nondirectory file))
 487     (epg-decrypt-file context file plain)
 488     (message "Decrypting %s...done" (file-name-nondirectory file))
 489     (if (epg-context-result-for context 'verify)
 490         (message "%s"
 491                  (epg-verify-result-to-string
 492                   (epg-context-result-for context 'verify))))))
 493
 494 ;;;###autoload
 495 (defun epa-verify-file (file)
 496   "Verify FILE."
 497   (interactive "fFile: ")
 498   (let* ((context (epg-make-context))
 499          (plain (if (equal (file-name-extension file) "sig")
 500                     (file-name-sans-extension file))))
 501     (message "Verifying %s..." (file-name-nondirectory file))
 502     (epg-verify-file context file plain)
 503     (message "Verifying %s...done" (file-name-nondirectory file))
 504     (message "%s"
 505              (epg-verify-result-to-string
 506               (epg-context-result-for context 'verify)))))
 507
 508 ;;;###autoload
 509 (defun epa-sign-file (file signers mode)
 510   "Sign FILE by SIGNERS keys selected."
 511   (interactive
 512    (list (expand-file-name (read-file-name "File: "))
 513          (epa-select-keys (epg-make-context) "Select keys for signing.
 514 If no one is selected, default secret key is used.  "
 515                           nil t)
 516          (if (y-or-n-p "Make a detached signature? ")
 517              'detached
 518            (if (y-or-n-p "Make a cleartext signature? ")
 519                'clear))))
 520   (let ((signature (concat file
 521                            (if (or epa-armor
 522                                    (not (memq mode '(nil t normal detached))))
 523                                ".asc"
 524                              (if (memq mode '(t detached))
 525                                  ".sig"
 526                                ".gpg"))))
 527         (context (epg-make-context)))
 528     (epg-context-set-armor context epa-armor)
 529     (epg-context-set-textmode context epa-textmode)
 530     (epg-context-set-signers context signers)
 531     (message "Signing %s..." (file-name-nondirectory file))
 532     (epg-sign-file context file signature mode)
 533     (message "Signing %s...done" (file-name-nondirectory file))))
 534
 535 ;;;###autoload
 536 (defun epa-encrypt-file (file recipients)
 537   "Encrypt FILE for RECIPIENTS."
 538   (interactive
 539    (list (expand-file-name (read-file-name "File: "))
 540          (epa-select-keys (epg-make-context) "Select recipents for encryption.
 541 If no one is selected, symmetric encryption will be performed.  ")))
 542   (let ((cipher (concat file (if epa-armor ".asc" ".gpg")))
 543         (context (epg-make-context)))
 544     (epg-context-set-armor context epa-armor)
 545     (epg-context-set-textmode context epa-textmode)
 546     (message "Encrypting %s..." (file-name-nondirectory file))
 547     (epg-encrypt-file context file recipients cipher)
 548     (message "Encrypting %s...done" (file-name-nondirectory file))))
 549
 550 ;;;###autoload
 551 (defun epa-decrypt-region (start end)
 552   "Decrypt the current region between START and END.
 553
 554 Don't use this command in Lisp programs!"
 555   (interactive "r")
 556   (save-excursion
 557     (let ((context (epg-make-context))
 558           plain)
 559       (message "Decrypting...")
 560       (setq plain (epg-decrypt-string context (buffer-substring start end)))
 561       (message "Decrypting...done")
 562       (delete-region start end)
 563       (goto-char start)
 564       (insert (decode-coding-string plain coding-system-for-read))
 565       (if (epg-context-result-for context 'verify)
 566           (message "%s"
 567                    (epg-verify-result-to-string
 568                     (epg-context-result-for context 'verify)))))))
 569
 570 ;;;###autoload
 571 (defun epa-decrypt-armor-in-region (start end)
 572   "Decrypt OpenPGP armors in the current region between START and END.
 573
 574 Don't use this command in Lisp programs!"
 575   (interactive "r")
 576   (save-excursion
 577     (save-restriction
 578       (narrow-to-region start end)
 579       (goto-char start)
 580       (let (armor-start armor-end charset coding-system)
 581         (while (re-search-forward "-----BEGIN PGP MESSAGE-----$" nil t)
 582           (setq armor-start (match-beginning 0)
 583                 armor-end (re-search-forward "^-----END PGP MESSAGE-----$"
 584                                              nil t))
 585           (unless armor-end
 586             (error "No armor tail"))
 587           (goto-char armor-start)
 588           (if (re-search-forward "^Charset: \\(.*\\)" armor-end t)
 589               (setq charset (match-string 1)))
 590           (if coding-system-for-read
 591               (setq coding-system coding-system-for-read)
 592             (if charset
 593                 (setq coding-system (intern (downcase charset)))
 594               (setq coding-system 'utf-8)))
 595           (let ((coding-system-for-read coding-system))
 596             (epa-decrypt-region start end)))))))
 597
 598 ;;;###autoload
 599 (defun epa-verify-region (start end)
 600   "Verify the current region between START and END.
 601
 602 Don't use this command in Lisp programs!"
 603   (interactive "r")
 604   (let ((context (epg-make-context)))
 605     (epg-verify-string context
 606                        (encode-coding-string
 607                         (buffer-substring start end)
 608                         coding-system-for-write))
 609     (message "%s"
 610              (epg-verify-result-to-string
 611               (epg-context-result-for context 'verify)))))
 612
 613 ;;;###autoload
 614 (defun epa-verify-armor-in-region (start end)
 615   "Verify OpenPGP armors in the current region between START and END.
 616
 617 Don't use this command in Lisp programs!"
 618   (interactive "r")
 619   (save-excursion
 620     (save-restriction
 621       (narrow-to-region start end)
 622       (goto-char start)
 623       (let (armor-start armor-end)
 624         (while (re-search-forward "-----BEGIN PGP\\( SIGNED\\)? MESSAGE-----$"
 625                                   nil t)
 626           (setq armor-start (match-beginning 0))
 627           (if (match-beginning 1)       ;cleartext signed message
 628               (progn
 629                 (unless (re-search-forward "^-----BEGIN PGP SIGNATURE-----$"
 630                                            nil t)
 631                   (error "Invalid cleartext signed message"))
 632                 (setq armor-end (re-search-forward
 633                                  "^-----END PGP SIGNATURE-----$"
 634                                  nil t)))
 635             (setq armor-end (re-search-forward
 636                              "^-----END PGP MESSAGE-----$"
 637                              nil t)))
 638           (unless armor-end
 639             (error "No armor tail"))
 640           (epa-verify-region armor-start armor-end))))))
 641
 642 ;;;###autoload
 643 (defun epa-sign-region (start end signers mode)
 644   "Sign the current region between START and END by SIGNERS keys selected.
 645
 646 Don't use this command in Lisp programs!"
 647   (interactive
 648    (list (region-beginning) (region-end)
 649          (epa-select-keys (epg-make-context) "Select keys for signing.
 650 If no one is selected, default secret key is used.  "
 651                           nil t)
 652          (if (y-or-n-p "Make a detached signature? ")
 653              'detached
 654            (if (y-or-n-p "Make a cleartext signature? ")
 655                'clear))))
 656   (save-excursion
 657     (let ((context (epg-make-context))
 658           signature)
 659       (epg-context-set-armor context epa-armor)
 660       (epg-context-set-textmode context epa-textmode)
 661       (epg-context-set-signers context signers)
 662       (message "Signing...")
 663       (setq signature (epg-sign-string context
 664                                        (encode-coding-string
 665                                         (buffer-substring start end)
 666                                         coding-system-for-write)
 667                                        mode))
 668       (message "Signing...done")
 669       (delete-region start end)
 670       (insert (decode-coding-string signature coding-system-for-read)))))
 671
 672 ;;;###autoload
 673 (defun epa-encrypt-region (start end recipients)
 674   "Encrypt the current region between START and END for RECIPIENTS.
 675
 676 Don't use this command in Lisp programs!"
 677   (interactive
 678    (list (region-beginning) (region-end)
 679          (epa-select-keys (epg-make-context) "Select recipents for encryption.
 680 If no one is selected, symmetric encryption will be performed.  ")))
 681   (save-excursion
 682     (let ((context (epg-make-context))
 683           cipher)
 684       (epg-context-set-armor context epa-armor)
 685       (epg-context-set-textmode context epa-textmode)
 686       (message "Encrypting...")
 687       (setq cipher (epg-encrypt-string context
 688                                        (encode-coding-string
 689                                         (buffer-substring start end)
 690                                         coding-system-for-write)
 691                                        recipients))
 692       (message "Encrypting...done")
 693       (delete-region start end)
 694       (insert cipher))))
 695
 696 ;;;###autoload
 697 (defun epa-delete-keys (keys &optional allow-secret)
 698   "Delete selected KEYS."
 699   (interactive
 700    (let ((keys (epa-marked-keys)))
 701      (unless keys
 702        (error "No keys selected"))
 703      (list keys
 704            (eq (nth 1 epa-list-keys-arguments) t))))
 705   (let ((context (epg-make-context)))
 706     (message "Deleting...")
 707     (epg-delete-keys context keys allow-secret)
 708     (message "Deleting...done")
 709     (apply #'epa-list-keys epa-list-keys-arguments)))
 710
 711 ;;;###autoload
 712 (defun epa-import-keys (file)
 713   "Import keys from FILE."
 714   (interactive "fFile: ")
 715   (let ((context (epg-make-context)))
 716     (message "Importing %s..." (file-name-nondirectory file))
 717     (epg-import-keys-from-file context (expand-file-name file))
 718     (message "Importing %s...done" (file-name-nondirectory file))
 719     (apply #'epa-list-keys epa-list-keys-arguments)))
 720
 721 ;;;###autoload
 722 (defun epa-export-keys (keys file)
 723   "Export selected KEYS to FILE."
 724   (interactive
 725    (let ((keys (epa-marked-keys))
 726          default-name)
 727      (unless keys
 728        (error "No keys selected"))
 729      (setq default-name
 730            (expand-file-name
 731             (concat (epg-sub-key-id (car (epg-key-sub-key-list (car keys))))
 732                     (if epa-armor ".asc" ".gpg"))
 733             default-directory))
 734      (list keys
 735            (expand-file-name
 736             (read-file-name
 737              (concat "To file (default "
 738                      (file-name-nondirectory default-name)
 739                      ") ")
 740              (file-name-directory default-name)
 741              default-name)))))
 742   (let ((context (epg-make-context)))
 743     (epg-context-set-armor context epa-armor)
 744     (message "Exporting to %s..." (file-name-nondirectory file))
 745     (epg-export-keys-to-file context keys file)
 746     (message "Exporting to %s...done" (file-name-nondirectory file))))
 747
 748 ;;;###autoload
 749 (defun epa-sign-keys (keys &optional local)
 750   "Sign selected KEYS.
 751 If LOCAL is non-nil, the signature is marked as non exportable."
 752   (interactive
 753    (let ((keys (epa-marked-keys)))
 754      (unless keys
 755        (error "No keys selected"))
 756      (list keys current-prefix-arg)))
 757   (let ((context (epg-make-context)))
 758     (message "Signing keys...")
 759     (epg-sign-keys context keys local)
 760     (message "Signing keys...done")))
 761
 762 (provide 'epa)
 763
 764 ;;; epa.el ends here