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