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