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