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 nil
  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 (defvar epa-info-buffer nil)
 169
 170 (defvar epa-keys-mode-map
 171   (let ((keymap (make-sparse-keymap)))
 172     (define-key keymap "m" 'epa-mark)
 173     (define-key keymap "u" 'epa-unmark)
 174     (define-key keymap "d" 'epa-decrypt-file)
 175     (define-key keymap "v" 'epa-verify-file)
 176     (define-key keymap "s" 'epa-sign-file)
 177     (define-key keymap "S" 'epa-sign-keys)
 178     (define-key keymap "e" 'epa-encrypt-file)
 179     (define-key keymap "r" 'epa-delete-keys)
 180     (define-key keymap "i" 'epa-import-keys)
 181     (define-key keymap "o" 'epa-export-keys)
 182     (define-key keymap "g" 'epa-list-keys)
 183     (define-key keymap "n" 'next-line)
 184     (define-key keymap "p" 'previous-line)
 185     (define-key keymap " " 'scroll-up)
 186     (define-key keymap [delete] 'scroll-down)
 187     (define-key keymap "q" 'epa-exit-buffer)
 188     keymap))
 189
 190 (defvar epa-key-mode-map
 191   (let ((keymap (make-sparse-keymap)))
 192     (define-key keymap "q" 'bury-buffer)
 193     keymap))
 194
 195 (defvar epa-info-mode-map
 196   (let ((keymap (make-sparse-keymap)))
 197     (define-key keymap "q" 'delete-window)
 198     keymap))
 199
 200 (defvar epa-exit-buffer-function #'bury-buffer)
 201
 202 (define-widget 'epa-key 'push-button
 203   "Button for representing a epg-key object."
 204   :format "%[%v%]"
 205   :button-face-get 'epa-key-widget-button-face-get
 206   :value-create 'epa-key-widget-value-create
 207   :action 'epa-key-widget-action
 208   :help-echo 'epa-key-widget-help-echo)
 209
 210 (defun epa-key-widget-action (widget &optional event)
 211   (epa-show-key (widget-get widget :value)))
 212
 213 (defun epa-key-widget-value-create (widget)
 214   (let* ((key (widget-get widget :value))
 215          (primary-sub-key (car (epg-key-sub-key-list key)))
 216          (primary-user-id (car (epg-key-user-id-list key))))
 217     (insert (format "%c "
 218                     (if (epg-sub-key-validity primary-sub-key)
 219                         (car (rassq (epg-sub-key-validity primary-sub-key)
 220                                     epg-key-validity-alist))
 221                       ? ))
 222             (epg-sub-key-id primary-sub-key)
 223             " "
 224             (if (stringp (epg-user-id-string primary-user-id))
 225                 (epg-user-id-string primary-user-id)
 226               (epg-decode-dn (epg-user-id-string primary-user-id))))))
 227
 228 (defun epa-key-widget-button-face-get (widget)
 229   (let ((validity (epg-sub-key-validity (car (epg-key-sub-key-list
 230                                               (widget-get widget :value))))))
 231     (if validity
 232         (cdr (assq validity epa-validity-face-alist))
 233       'default)))
 234
 235 (defun epa-key-widget-help-echo (widget)
 236   (format "Show %s"
 237           (epg-sub-key-id (car (epg-key-sub-key-list
 238                                 (widget-get widget :value))))))
 239
 240 (defun epa-keys-mode ()
 241   "Major mode for `epa-list-keys'."
 242   (kill-all-local-variables)
 243   (buffer-disable-undo)
 244   (setq major-mode 'epa-keys-mode
 245         mode-name "Keys"
 246         truncate-lines t
 247         buffer-read-only t)
 248   (use-local-map epa-keys-mode-map)
 249   (set-keymap-parent (current-local-map) widget-keymap)
 250   (make-local-variable 'font-lock-defaults)
 251   (setq font-lock-defaults '(epa-font-lock-keywords t))
 252   ;; In XEmacs, auto-initialization of font-lock is not effective
 253   ;; if buffer-file-name is not set.
 254   (font-lock-set-defaults)
 255   (widget-setup)
 256   (make-local-variable 'epa-exit-buffer-function)
 257   (run-hooks 'epa-keys-mode-hook))
 258
 259 (defun epa-key-mode ()
 260   "Major mode for `epa-show-key'."
 261   (kill-all-local-variables)
 262   (buffer-disable-undo)
 263   (setq major-mode 'epa-key-mode
 264         mode-name "Key"
 265         truncate-lines t
 266         buffer-read-only t)
 267   (use-local-map epa-key-mode-map)
 268   (make-local-variable 'font-lock-defaults)
 269   (setq font-lock-defaults '(epa-font-lock-keywords t))
 270   ;; In XEmacs, auto-initialization of font-lock is not effective
 271   ;; if buffer-file-name is not set.
 272   (font-lock-set-defaults)
 273   (make-local-variable 'epa-exit-buffer-function)
 274   (run-hooks 'epa-key-mode-hook))
 275
 276 ;;;###autoload
 277 (defun epa-list-keys (&optional name mode protocol)
 278   (interactive
 279    (if current-prefix-arg
 280        (let ((name (read-string "Pattern: "
 281                                 (if epa-list-keys-arguments
 282                                     (car epa-list-keys-arguments)))))
 283          (list (if (equal name "") nil name)
 284                (y-or-n-p "Secret keys? ")
 285                (intern (completing-read "Protocol? "
 286                                         '(("OpenPGP") ("CMS"))
 287                                         nil t))))
 288      (or epa-list-keys-arguments (list nil nil nil))))
 289   (unless (and epa-keys-buffer
 290                (buffer-live-p epa-keys-buffer))
 291     (setq epa-keys-buffer (generate-new-buffer "*Keys*")))
 292   (set-buffer epa-keys-buffer)
 293   (let ((inhibit-read-only t)
 294         buffer-read-only
 295         (point (point-min))
 296         (context (epg-make-context protocol)))
 297     (unless (get-text-property point 'epa-list-keys)
 298       (setq point (next-single-property-change point 'epa-list-keys)))
 299     (when point
 300       (delete-region point
 301                      (or (next-single-property-change point 'epa-list-keys)
 302                          (point-max)))
 303       (goto-char point))
 304     (epa-insert-keys context name mode)
 305     (epa-keys-mode))
 306   (make-local-variable 'epa-list-keys-arguments)
 307   (setq epa-list-keys-arguments (list name mode protocol))
 308   (goto-char (point-min))
 309   (pop-to-buffer (current-buffer)))
 310
 311 (defun epa-insert-keys (context name mode)
 312   (save-excursion
 313     (save-restriction
 314       (narrow-to-region (point) (point))
 315       (let ((keys (epg-list-keys context name mode))
 316             point)
 317         (while keys
 318           (setq point (point))
 319           (insert "  ")
 320           (add-text-properties point (point)
 321                                (list 'epa-key (car keys)
 322                                      'front-sticky nil
 323                                      'rear-nonsticky t
 324                                      'start-open t
 325                                      'end-open t))
 326           (widget-create 'epa-key :value (car keys))
 327           (insert "\n")
 328           (setq keys (cdr keys))))
 329       (add-text-properties (point-min) (point-max)
 330                            (list 'epa-list-keys t
 331                                  'front-sticky nil
 332                                  'rear-nonsticky t
 333                                  'start-open t
 334                                  'end-open t)))))
 335
 336 (defun epa-marked-keys ()
 337   (or (save-excursion
 338         (set-buffer epa-keys-buffer)
 339         (goto-char (point-min))
 340         (let (keys key)
 341           (while (re-search-forward "^\\*" nil t)
 342             (if (setq key (get-text-property (match-beginning 0)
 343                                              'epa-key))
 344                 (setq keys (cons key keys))))
 345           (nreverse keys)))
 346       (save-excursion
 347         (beginning-of-line)
 348         (let ((key (get-text-property (point) 'epa-key)))
 349           (if key
 350               (list key))))))
 351
 352 ;;;###autoload
 353 (defun epa-select-keys (context prompt &optional names secret)
 354   "Display a user's keyring and ask him to select keys.
 355 CONTEXT is an epg-context.
 356 PROMPT is a string to prompt with.
 357 NAMES is a list of strings to be matched with keys.  If it is nil, all
 358 the keys are listed.
 359 If SECRET is non-nil, list secret keys instead of public keys."
 360   (save-excursion
 361     (unless (and epa-keys-buffer
 362                  (buffer-live-p epa-keys-buffer))
 363       (setq epa-keys-buffer (generate-new-buffer "*Keys*")))
 364     (let ((inhibit-read-only t)
 365           buffer-read-only)
 366       (set-buffer epa-keys-buffer)
 367       (erase-buffer)
 368       (insert prompt "\n")
 369       (widget-create 'link
 370                      :notify (lambda (&rest ignore) (abort-recursive-edit))
 371                      :help-echo
 372                      (substitute-command-keys
 373                       "Click here or \\[abort-recursive-edit] to cancel")
 374                      "Cancel")
 375       (widget-create 'link
 376                      :notify (lambda (&rest ignore) (exit-recursive-edit))
 377                      :help-echo
 378                      (substitute-command-keys
 379                       "Click here or \\[exit-recursive-edit] to finish")
 380                      "OK")
 381       (insert "\n\n")
 382       (if names
 383           (while names
 384             (epa-insert-keys context (car names) secret)
 385             (if (get-text-property (point) 'epa-list-keys)
 386                 (epa-mark))
 387             (goto-char (point-max))
 388             (setq names (cdr names)))
 389         (if secret
 390             (progn
 391               (epa-insert-keys context nil secret)
 392               (if (get-text-property (point) 'epa-list-keys)
 393                   (epa-mark)))
 394           (epa-insert-keys context nil nil)))
 395       (epa-keys-mode)
 396       (setq epa-exit-buffer-function #'abort-recursive-edit)
 397       (goto-char (point-min))
 398       (pop-to-buffer (current-buffer)))
 399     (unwind-protect
 400         (progn
 401           (recursive-edit)
 402           (epa-marked-keys))
 403       (if (get-buffer-window epa-keys-buffer)
 404           (delete-window (get-buffer-window epa-keys-buffer)))
 405       (kill-buffer epa-keys-buffer))))
 406
 407 (defun epa-show-key (key)
 408   (let* ((primary-sub-key (car (epg-key-sub-key-list key)))
 409          (entry (assoc (epg-sub-key-id primary-sub-key)
 410                        epa-key-buffer-alist))
 411          (inhibit-read-only t)
 412          buffer-read-only
 413          pointer)
 414     (unless entry
 415       (setq entry (cons (epg-sub-key-id primary-sub-key) nil)
 416             epa-key-buffer-alist (cons entry epa-key-buffer-alist)))
 417     (unless (and (cdr entry)
 418                  (buffer-live-p (cdr entry)))
 419       (setcdr entry (generate-new-buffer
 420                      (format "*Key*%s" (epg-sub-key-id primary-sub-key)))))
 421     (set-buffer (cdr entry))
 422     (make-local-variable 'epa-key)
 423     (setq epa-key key)
 424     (erase-buffer)
 425     (setq pointer (epg-key-user-id-list key))
 426     (while pointer
 427       (insert " "
 428               (if (epg-user-id-validity (car pointer))
 429                   (char-to-string
 430                    (car (rassq (epg-user-id-validity (car pointer))
 431                                epg-key-validity-alist)))
 432                 " ")
 433               " "
 434               (if (stringp (epg-user-id-string (car pointer)))
 435                   (epg-user-id-string (car pointer))
 436                 (epg-decode-dn (epg-user-id-string (car pointer))))
 437               "\n")
 438       (setq pointer (cdr pointer)))
 439     (setq pointer (epg-key-sub-key-list key))
 440     (while pointer
 441       (insert " "
 442               (if (epg-sub-key-validity (car pointer))
 443                   (char-to-string
 444                    (car (rassq (epg-sub-key-validity (car pointer))
 445                                epg-key-validity-alist)))
 446                 " ")
 447               " "
 448               (epg-sub-key-id (car pointer))
 449               " "
 450               (format "%dbits"
 451                       (epg-sub-key-length (car pointer)))
 452               " "
 453               (cdr (assq (epg-sub-key-algorithm (car pointer))
 454                          epg-pubkey-algorithm-alist))
 455               "\n\tCreated: "
 456               (format-time-string "%Y-%m-%d"
 457                                   (epg-sub-key-creation-time (car pointer)))
 458               (if (epg-sub-key-expiration-time (car pointer))
 459                   (format "\n\tExpires: %s"
 460                           (format-time-string "%Y-%m-%d"
 461                                               (epg-sub-key-expiration-time
 462                                                (car pointer))))
 463                 "")
 464               "\n\tCapabilities: "
 465               (mapconcat #'symbol-name
 466                          (epg-sub-key-capability (car pointer))
 467                          " ")
 468               "\n\tFingerprint: "
 469               (epg-sub-key-fingerprint (car pointer))
 470               "\n")
 471       (setq pointer (cdr pointer)))
 472     (goto-char (point-min))
 473     (pop-to-buffer (current-buffer))
 474     (epa-key-mode)))
 475
 476 (defun epa-show-key-notify (widget &rest ignore)
 477   (epa-show-key (widget-get widget :value)))
 478
 479 (defun epa-mark (&optional arg)
 480   "Mark the current line.
 481 If ARG is non-nil, unmark the current line."
 482   (interactive "P")
 483   (let ((inhibit-read-only t)
 484         buffer-read-only
 485         properties)
 486     (beginning-of-line)
 487     (setq properties (text-properties-at (point)))
 488     (delete-char 1)
 489     (insert (if arg " " "*"))
 490     (set-text-properties (1- (point)) (point) properties)
 491     (forward-line)))
 492
 493 (defun epa-unmark (&optional arg)
 494   "Unmark the current line.
 495 If ARG is non-nil, mark the current line."
 496   (interactive "P")
 497   (epa-mark (not arg)))
 498
 499 (defun epa-toggle-mark ()
 500   "Toggle the mark the current line."
 501   (interactive)
 502   (epa-mark (eq (char-after (save-excursion (beginning-of-line) (point))) ?*)))
 503
 504 (defun epa-exit-buffer ()
 505   "Exit the current buffer.
 506 `epa-exit-buffer-function' is called if it is set."
 507   (interactive)
 508   (funcall epa-exit-buffer-function))
 509
 510 (defun epa-display-verify-result (verify-result)
 511   (if epa-popup-info-window
 512       (progn
 513         (unless epa-info-buffer
 514           (setq epa-info-buffer (generate-new-buffer "*Info*")))
 515         (save-excursion
 516           (set-buffer epa-info-buffer)
 517           (let ((inhibit-read-only t)
 518                 buffer-read-only)
 519             (erase-buffer)
 520             (insert (epg-verify-result-to-string verify-result)))
 521           (epa-info-mode))
 522         (pop-to-buffer epa-info-buffer)
 523         (if (> (window-height) epa-info-window-height)
 524             (shrink-window (- (window-height) epa-info-window-height)))
 525         (goto-char (point-min)))
 526     (message "%s" (epg-verify-result-to-string verify-result))))
 527
 528 (defun epa-info-mode ()
 529   "Major mode for `epa-info-buffer'."
 530   (kill-all-local-variables)
 531   (buffer-disable-undo)
 532   (setq major-mode 'epa-info-mode
 533         mode-name "Info"
 534         truncate-lines t
 535         buffer-read-only t)
 536   (use-local-map epa-info-mode-map)
 537   (run-hooks 'epa-info-mode-hook))
 538
 539 ;;;###autoload
 540 (defun epa-decrypt-file (file)
 541   "Decrypt FILE."
 542   (interactive "fFile: ")
 543   (let* ((default-name (file-name-sans-extension file))
 544          (plain (expand-file-name
 545                  (read-file-name
 546                   (concat "To file (default "
 547                           (file-name-nondirectory default-name)
 548                           ") ")
 549                   (file-name-directory default-name)
 550                   default-name)))
 551          (context (epg-make-context)))
 552     (epg-context-set-passphrase-callback context
 553                                          #'epa-passphrase-callback-function)
 554     (message "Decrypting %s..." (file-name-nondirectory file))
 555     (epg-decrypt-file context file plain)
 556     (message "Decrypting %s...done" (file-name-nondirectory file))
 557     (if (epg-context-result-for context 'verify)
 558         (epa-display-verify-result (epg-context-result-for context 'verify)))))
 559
 560 ;;;###autoload
 561 (defun epa-verify-file (file)
 562   "Verify FILE."
 563   (interactive "fFile: ")
 564   (let* ((context (epg-make-context))
 565          (plain (if (equal (file-name-extension file) "sig")
 566                     (file-name-sans-extension file))))
 567     (message "Verifying %s..." (file-name-nondirectory file))
 568     (epg-verify-file context file plain)
 569     (message "Verifying %s...done" (file-name-nondirectory file))
 570     (if (epg-context-result-for context 'verify)
 571         (epa-display-verify-result (epg-context-result-for context 'verify)))))
 572
 573 ;;;###autoload
 574 (defun epa-sign-file (file signers mode)
 575   "Sign FILE by SIGNERS keys selected."
 576   (interactive
 577    (list (expand-file-name (read-file-name "File: "))
 578          (epa-select-keys (epg-make-context) "Select keys for signing.
 579 If no one is selected, default secret key is used.  "
 580                           nil t)
 581          (if (y-or-n-p "Make a detached signature? ")
 582              'detached
 583            (if (y-or-n-p "Make a cleartext signature? ")
 584                'clear))))
 585   (let ((signature (concat file
 586                            (if (or epa-armor
 587                                    (not (memq mode '(nil t normal detached))))
 588                                ".asc"
 589                              (if (memq mode '(t detached))
 590                                  ".sig"
 591                                ".gpg"))))
 592         (context (epg-make-context)))
 593     (epg-context-set-armor context epa-armor)
 594     (epg-context-set-textmode context epa-textmode)
 595     (epg-context-set-signers context signers)
 596     (epg-context-set-passphrase-callback context
 597                                          #'epa-passphrase-callback-function)
 598     (message "Signing %s..." (file-name-nondirectory file))
 599     (epg-sign-file context file signature mode)
 600     (message "Signing %s...done" (file-name-nondirectory file))))
 601
 602 ;;;###autoload
 603 (defun epa-encrypt-file (file recipients)
 604   "Encrypt FILE for RECIPIENTS."
 605   (interactive
 606    (list (expand-file-name (read-file-name "File: "))
 607          (epa-select-keys (epg-make-context) "Select recipients for encryption.
 608 If no one is selected, symmetric encryption will be performed.  ")))
 609   (let ((cipher (concat file (if epa-armor ".asc" ".gpg")))
 610         (context (epg-make-context)))
 611     (epg-context-set-armor context epa-armor)
 612     (epg-context-set-textmode context epa-textmode)
 613     (epg-context-set-passphrase-callback context
 614                                          #'epa-passphrase-callback-function)
 615     (message "Encrypting %s..." (file-name-nondirectory file))
 616     (epg-encrypt-file context file recipients cipher)
 617     (message "Encrypting %s...done" (file-name-nondirectory file))))
 618
 619 ;;;###autoload
 620 (defun epa-decrypt-region (start end)
 621   "Decrypt the current region between START and END.
 622
 623 Don't use this command in Lisp programs!"
 624   (interactive "r")
 625   (save-excursion
 626     (let ((context (epg-make-context))
 627           plain)
 628       (epg-context-set-passphrase-callback context
 629                                            #'epa-passphrase-callback-function)
 630       (message "Decrypting...")
 631       (setq plain (epg-decrypt-string context (buffer-substring start end)))
 632       (message "Decrypting...done")
 633       (delete-region start end)
 634       (goto-char start)
 635       (insert (decode-coding-string plain coding-system-for-read))
 636       (if (epg-context-result-for context 'verify)
 637           (epa-display-verify-result (epg-context-result-for context 'verify))))))
 638
 639 ;;;###autoload
 640 (defun epa-decrypt-armor-in-region (start end)
 641   "Decrypt OpenPGP armors in the current region between START and END.
 642
 643 Don't use this command in Lisp programs!"
 644   (interactive "r")
 645   (save-excursion
 646     (save-restriction
 647       (narrow-to-region start end)
 648       (goto-char start)
 649       (let (armor-start armor-end charset coding-system)
 650         (while (re-search-forward "-----BEGIN PGP MESSAGE-----$" nil t)
 651           (setq armor-start (match-beginning 0)
 652                 armor-end (re-search-forward "^-----END PGP MESSAGE-----$"
 653                                              nil t))
 654           (unless armor-end
 655             (error "No armor tail"))
 656           (goto-char armor-start)
 657           (if (re-search-forward "^Charset: \\(.*\\)" armor-end t)
 658               (setq charset (match-string 1)))
 659           (if coding-system-for-read
 660               (setq coding-system coding-system-for-read)
 661             (if charset
 662                 (setq coding-system (intern (downcase charset)))
 663               (setq coding-system 'utf-8)))
 664           (let ((coding-system-for-read coding-system))
 665             (epa-decrypt-region start end)))))))
 666
 667 ;;;###autoload
 668 (defun epa-verify-region (start end)
 669   "Verify the current region between START and END.
 670
 671 Don't use this command in Lisp programs!"
 672   (interactive "r")
 673   (let ((context (epg-make-context)))
 674     (epg-verify-string context
 675                        (encode-coding-string
 676                         (buffer-substring start end)
 677                         coding-system-for-write))
 678     (if (epg-context-result-for context 'verify)
 679         (epa-display-verify-result (epg-context-result-for context 'verify)))))
 680
 681 ;;;###autoload
 682 (defun epa-verify-armor-in-region (start end)
 683   "Verify OpenPGP armors in the current region between START and END.
 684
 685 Don't use this command in Lisp programs!"
 686   (interactive "r")
 687   (save-excursion
 688     (save-restriction
 689       (narrow-to-region start end)
 690       (goto-char start)
 691       (let (armor-start armor-end)
 692         (while (re-search-forward "-----BEGIN PGP\\( SIGNED\\)? MESSAGE-----$"
 693                                   nil t)
 694           (setq armor-start (match-beginning 0))
 695           (if (match-beginning 1)       ;cleartext signed message
 696               (progn
 697                 (unless (re-search-forward "^-----BEGIN PGP SIGNATURE-----$"
 698                                            nil t)
 699                   (error "Invalid cleartext signed message"))
 700                 (setq armor-end (re-search-forward
 701                                  "^-----END PGP SIGNATURE-----$"
 702                                  nil t)))
 703             (setq armor-end (re-search-forward
 704                              "^-----END PGP MESSAGE-----$"
 705                              nil t)))
 706           (unless armor-end
 707             (error "No armor tail"))
 708           (epa-verify-region armor-start armor-end))))))
 709
 710 ;;;###autoload
 711 (defun epa-sign-region (start end signers mode)
 712   "Sign the current region between START and END by SIGNERS keys selected.
 713
 714 Don't use this command in Lisp programs!"
 715   (interactive
 716    (list (region-beginning) (region-end)
 717          (epa-select-keys (epg-make-context) "Select keys for signing.
 718 If no one is selected, default secret key is used.  "
 719                           nil t)
 720          (if (y-or-n-p "Make a detached signature? ")
 721              'detached
 722            (if (y-or-n-p "Make a cleartext signature? ")
 723                'clear))))
 724   (save-excursion
 725     (let ((context (epg-make-context))
 726           signature)
 727       (epg-context-set-armor context epa-armor)
 728       (epg-context-set-textmode context epa-textmode)
 729       (epg-context-set-signers context signers)
 730       (epg-context-set-passphrase-callback context
 731                                            #'epa-passphrase-callback-function)
 732       (message "Signing...")
 733       (setq signature (epg-sign-string context
 734                                        (encode-coding-string
 735                                         (buffer-substring start end)
 736                                         coding-system-for-write)
 737                                        mode))
 738       (message "Signing...done")
 739       (delete-region start end)
 740       (insert (decode-coding-string signature coding-system-for-read)))))
 741
 742 ;;;###autoload
 743 (defun epa-encrypt-region (start end recipients)
 744   "Encrypt the current region between START and END for RECIPIENTS.
 745
 746 Don't use this command in Lisp programs!"
 747   (interactive
 748    (list (region-beginning) (region-end)
 749          (epa-select-keys (epg-make-context) "Select recipients for encryption.
 750 If no one is selected, symmetric encryption will be performed.  ")))
 751   (save-excursion
 752     (let ((context (epg-make-context))
 753           cipher)
 754       (epg-context-set-armor context epa-armor)
 755       (epg-context-set-textmode context epa-textmode)
 756       (epg-context-set-passphrase-callback context
 757                                            #'epa-passphrase-callback-function)
 758       (message "Encrypting...")
 759       (setq cipher (epg-encrypt-string context
 760                                        (encode-coding-string
 761                                         (buffer-substring start end)
 762                                         coding-system-for-write)
 763                                        recipients))
 764       (message "Encrypting...done")
 765       (delete-region start end)
 766       (insert cipher))))
 767
 768 ;;;###autoload
 769 (defun epa-delete-keys (keys &optional allow-secret)
 770   "Delete selected KEYS."
 771   (interactive
 772    (let ((keys (epa-marked-keys)))
 773      (unless keys
 774        (error "No keys selected"))
 775      (list keys
 776            (eq (nth 1 epa-list-keys-arguments) t))))
 777   (let ((context (epg-make-context)))
 778     (message "Deleting...")
 779     (epg-delete-keys context keys allow-secret)
 780     (message "Deleting...done")
 781     (apply #'epa-list-keys epa-list-keys-arguments)))
 782
 783 ;;;###autoload
 784 (defun epa-import-keys (file)
 785   "Import keys from FILE."
 786   (interactive "fFile: ")
 787   (let ((context (epg-make-context)))
 788     (message "Importing %s..." (file-name-nondirectory file))
 789     (epg-import-keys-from-file context (expand-file-name file))
 790     (message "Importing %s...done" (file-name-nondirectory file))
 791     (apply #'epa-list-keys epa-list-keys-arguments)))
 792
 793 ;;;###autoload
 794 (defun epa-export-keys (keys file)
 795   "Export selected KEYS to FILE."
 796   (interactive
 797    (let ((keys (epa-marked-keys))
 798          default-name)
 799      (unless keys
 800        (error "No keys selected"))
 801      (setq default-name
 802            (expand-file-name
 803             (concat (epg-sub-key-id (car (epg-key-sub-key-list (car keys))))
 804                     (if epa-armor ".asc" ".gpg"))
 805             default-directory))
 806      (list keys
 807            (expand-file-name
 808             (read-file-name
 809              (concat "To file (default "
 810                      (file-name-nondirectory default-name)
 811                      ") ")
 812              (file-name-directory default-name)
 813              default-name)))))
 814   (let ((context (epg-make-context)))
 815     (epg-context-set-armor context epa-armor)
 816     (message "Exporting to %s..." (file-name-nondirectory file))
 817     (epg-export-keys-to-file context keys file)
 818     (message "Exporting to %s...done" (file-name-nondirectory file))))
 819
 820 ;;;###autoload
 821 (defun epa-sign-keys (keys &optional local)
 822   "Sign selected KEYS.
 823 If LOCAL is non-nil, the signature is marked as non exportable."
 824   (interactive
 825    (let ((keys (epa-marked-keys)))
 826      (unless keys
 827        (error "No keys selected"))
 828      (list keys current-prefix-arg)))
 829   (let ((context (epg-make-context)))
 830     (epg-context-set-passphrase-callback context
 831                                          #'epa-passphrase-callback-function)
 832     (message "Signing keys...")
 833     (epg-sign-keys context keys local)
 834     (message "Signing keys...done")))
 835
 836 (defun epa-passphrase-callback-function (context key-id handback)
 837   (if (eq key-id 'SYM)
 838       (read-passwd "Passphrase for symmetric encryption: "
 839                    (eq (epg-context-operation context) 'encrypt))
 840     (read-passwd
 841      (if (eq key-id 'PIN)
 842         "Passphrase for PIN: "
 843        (let ((entry (assoc key-id epg-user-id-alist)))
 844          (if entry
 845              (format "Passphrase for %s %s: " key-id (cdr entry))
 846            (format "Passphrase for %s: " key-id)))))))
 847
 848 (defun epa-progress-callback-function (context what char current total
 849                                                handback)
 850   (message "%s: %d%% (%d/%d)" what
 851            (if (> total 0) (floor (* (/ current (float total)) 100)) 0)
 852            current total))
 853
 854 (provide 'epa)
 855
 856 ;;; epa.el ends here