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