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 (require 'derived)
  31
  32 (defgroup epa nil
  33   "The EasyPG Assistant"
  34   :group 'epg)
  35
  36 (defcustom epa-popup-info-window t
  37   "If non-nil, status information from epa commands is displayed on
  38 the separate window."
  39   :type 'boolean
  40   :group 'epa)
  41
  42 (defcustom epa-info-window-height 5
  43   "Number of lines used to display status information."
  44   :type 'integer
  45   :group 'epa)
  46
  47 (defgroup epa-faces nil
  48   "Faces for epa-mode."
  49   :group 'epa)
  50
  51 (defface epa-validity-high-face
  52   '((((class color) (background dark))
  53      (:foreground "PaleTurquoise" :bold t))
  54     (t
  55      (:bold t)))
  56   "Face used for displaying the high validity."
  57   :group 'epa-faces)
  58 (defvar epa-validity-high-face 'epa-validity-high-face)
  59
  60 (defface epa-validity-medium-face
  61   '((((class color) (background dark))
  62      (:foreground "PaleTurquoise" :italic t))
  63     (t
  64      ()))
  65   "Face used for displaying the medium validity."
  66   :group 'epa-faces)
  67 (defvar epa-validity-medium-face 'epa-validity-medium-face)
  68
  69 (defface epa-validity-low-face
  70   '((t
  71      (:italic t)))
  72   "Face used for displaying the low validity."
  73   :group 'epa-faces)
  74 (defvar epa-validity-low-face 'epa-validity-low-face)
  75
  76 (defface epa-validity-disabled-face
  77   '((t
  78      (:italic t :inverse-video t)))
  79   "Face used for displaying the disabled validity."
  80   :group 'epa-faces)
  81 (defvar epa-validity-disabled-face 'epa-validity-disabled-face)
  82
  83 (defface epa-string-face
  84   '((((class color)
  85       (background dark))
  86      (:foreground "lightyellow"))
  87     (((class color)
  88       (background light))
  89      (:foreground "blue4"))
  90     (t
  91      ()))
  92   "Face used for displaying the string."
  93   :group 'epa-faces)
  94 (defvar epa-string-face 'epa-string-face)
  95
  96 (defface epa-mark-face
  97   '((((class color) (background dark))
  98      (:foreground "orange" :bold t))
  99     (t
 100      (:foreground "red" :bold t)))
 101   "Face used for displaying the high validity."
 102   :group 'epa-faces)
 103 (defvar epa-mark-face 'epa-mark-face)
 104
 105 (defface epa-field-name-face
 106   '((((class color) (background dark))
 107      (:foreground "PaleTurquoise" :bold t))
 108     (t (:bold t)))
 109   "Face for the name of the attribute field."
 110   :group 'epa)
 111 (defvar epa-field-name-face 'epa-field-name-face)
 112
 113 (defface epa-field-body-face
 114   '((((class color) (background dark))
 115      (:foreground "turquoise" :italic t))
 116     (t (:italic t)))
 117   "Face for the body of the attribute field."
 118   :group 'epa)
 119 (defvar epa-field-body-face 'epa-field-body-face)
 120
 121 (defcustom epa-validity-face-alist
 122   '((unknown . epa-validity-disabled-face)
 123     (invalid . epa-validity-disabled-face)
 124     (disabled . epa-validity-disabled-face)
 125     (revoked . epa-validity-disabled-face)
 126     (expired . epa-validity-disabled-face)
 127     (none . epa-validity-low-face)
 128     (undefined . epa-validity-low-face)
 129     (never . epa-validity-low-face)
 130     (marginal . epa-validity-medium-face)
 131     (full . epa-validity-high-face)
 132     (ultimate . epa-validity-high-face))
 133   "An alist mapping validity values to faces."
 134   :type 'list
 135   :group 'epa)
 136
 137 (defcustom epa-font-lock-keywords
 138   '(("^\\*"
 139      (0 epa-mark-face))
 140     ("^\t\\([^\t:]+:\\)[ \t]*\\(.*\\)$"
 141      (1 epa-field-name-face)
 142      (2 epa-field-body-face)))
 143   "Default expressions to addon in epa-mode."
 144   :type '(repeat (list string))
 145   :group 'epa)
 146
 147 (defconst epa-pubkey-algorithm-letter-alist
 148   '((1 . ?R)
 149     (2 . ?r)
 150     (3 . ?s)
 151     (16 . ?g)
 152     (17 . ?D)
 153     (20 . ?G)))
 154
 155 (defvar epa-protocol 'OpenPGP
 156   "*The default protocol.
 157 The values can be either OpenPGP or CMS.
 158 You should bind this variable with `let', but do not set it globally.")
 159
 160 (defvar epa-armor nil
 161   "*If non-nil, epa commands create ASCII armored output.
 162 You should bind this variable with `let', but do not set it globally.")
 163
 164 (defvar epa-textmode nil
 165   "*If non-nil, epa commands treat input files as text.
 166 You should bind this variable with `let', but do not set it globally.")
 167
 168 (defvar epa-keys-buffer nil)
 169 (defvar epa-key-buffer-alist nil)
 170 (defvar epa-key nil)
 171 (defvar epa-list-keys-arguments nil)
 172 (defvar epa-info-buffer nil)
 173 (defvar epa-last-coding-system-specified nil)
 174
 175 (defvar epa-key-list-mode-map
 176   (let ((keymap (make-sparse-keymap)))
 177     (define-key keymap "m" 'epa-mark)
 178     (define-key keymap "u" 'epa-unmark)
 179     (define-key keymap "d" 'epa-decrypt-file)
 180     (define-key keymap "v" 'epa-verify-file)
 181     (define-key keymap "s" 'epa-sign-file)
 182     (define-key keymap "e" 'epa-encrypt-file)
 183     (define-key keymap "r" 'epa-delete-keys)
 184     (define-key keymap "i" 'epa-import-keys)
 185     (define-key keymap "o" 'epa-export-keys)
 186     (define-key keymap "g" 'revert-buffer)
 187     (define-key keymap "n" 'next-line)
 188     (define-key keymap "p" 'previous-line)
 189     (define-key keymap " " 'scroll-up)
 190     (define-key keymap [delete] 'scroll-down)
 191     (define-key keymap "q" 'epa-exit-buffer)
 192     keymap))
 193
 194 (defvar epa-key-mode-map
 195   (let ((keymap (make-sparse-keymap)))
 196     (define-key keymap "q" 'bury-buffer)
 197     keymap))
 198
 199 (defvar epa-info-mode-map
 200   (let ((keymap (make-sparse-keymap)))
 201     (define-key keymap "q" 'delete-window)
 202     keymap))
 203
 204 (defvar epa-exit-buffer-function #'bury-buffer)
 205
 206 (define-widget 'epa-key 'push-button
 207   "Button for representing a epg-key object."
 208   :format "%[%v%]"
 209   :button-face-get 'epa--key-widget-button-face-get
 210   :value-create 'epa--key-widget-value-create
 211   :action 'epa--key-widget-action
 212   :help-echo 'epa--key-widget-help-echo)
 213
 214 (defun epa--key-widget-action (widget &optional event)
 215   (epa--show-key (widget-get widget :value)))
 216
 217 (defun epa--key-widget-value-create (widget)
 218   (let* ((key (widget-get widget :value))
 219          (primary-sub-key (car (epg-key-sub-key-list key)))
 220          (primary-user-id (car (epg-key-user-id-list key))))
 221     (insert (format "%c "
 222                     (if (epg-sub-key-validity primary-sub-key)
 223                         (car (rassq (epg-sub-key-validity primary-sub-key)
 224                                     epg-key-validity-alist))
 225                       ? ))
 226             (epg-sub-key-id primary-sub-key)
 227             " "
 228             (if primary-user-id
 229                 (if (stringp (epg-user-id-string primary-user-id))
 230                     (epg-user-id-string primary-user-id)
 231                   (epg-decode-dn (epg-user-id-string primary-user-id)))
 232               ""))))
 233
 234 (defun epa--key-widget-button-face-get (widget)
 235   (let ((validity (epg-sub-key-validity (car (epg-key-sub-key-list
 236                                               (widget-get widget :value))))))
 237     (if validity
 238         (cdr (assq validity epa-validity-face-alist))
 239       'default)))
 240
 241 (defun epa--key-widget-help-echo (widget)
 242   (format "Show %s"
 243           (epg-sub-key-id (car (epg-key-sub-key-list
 244                                 (widget-get widget :value))))))
 245
 246 (if (fboundp 'encode-coding-string)
 247     (defalias 'epa--encode-coding-string 'encode-coding-string)
 248   (defalias 'epa--encode-coding-string 'identity))
 249
 250 (if (fboundp 'decode-coding-string)
 251     (defalias 'epa--decode-coding-string 'decode-coding-string)
 252   (defalias 'epa--decode-coding-string 'identity))
 253
 254 (defun epa-key-list-mode ()
 255   "Major mode for `epa-list-keys'."
 256   (kill-all-local-variables)
 257   (buffer-disable-undo)
 258   (setq major-mode 'epa-key-list-mode
 259         mode-name "Keys"
 260         truncate-lines t
 261         buffer-read-only t)
 262   (use-local-map epa-key-list-mode-map)
 263   (make-local-variable 'font-lock-defaults)
 264   (setq font-lock-defaults '(epa-font-lock-keywords t))
 265   ;; In XEmacs, auto-initialization of font-lock is not effective
 266   ;; if buffer-file-name is not set.
 267   (font-lock-set-defaults)
 268   (make-local-variable 'epa-exit-buffer-function)
 269   (make-local-variable 'revert-buffer-function)
 270   (setq revert-buffer-function 'epa--key-list-revert-buffer)
 271   (run-hooks 'epa-key-list-mode-hook))
 272
 273 (defun epa-key-mode ()
 274   "Major mode for a key description."
 275   (kill-all-local-variables)
 276   (buffer-disable-undo)
 277   (setq major-mode 'epa-key-mode
 278         mode-name "Key"
 279         truncate-lines t
 280         buffer-read-only t)
 281   (use-local-map epa-key-mode-map)
 282   (make-local-variable 'font-lock-defaults)
 283   (setq font-lock-defaults '(epa-font-lock-keywords t))
 284   ;; In XEmacs, auto-initialization of font-lock is not effective
 285   ;; if buffer-file-name is not set.
 286   (font-lock-set-defaults)
 287   (make-local-variable 'epa-exit-buffer-function)
 288   (run-hooks 'epa-key-mode-hook))
 289
 290 (defun epa-info-mode ()
 291   "Major mode for `epa-info-buffer'."
 292   (kill-all-local-variables)
 293   (buffer-disable-undo)
 294   (setq major-mode 'epa-info-mode
 295         mode-name "Info"
 296         truncate-lines t
 297         buffer-read-only t)
 298   (use-local-map epa-info-mode-map)
 299   (run-hooks 'epa-info-mode-hook))
 300
 301 (defun epa-mark (&optional arg)
 302   "Mark the current line.
 303 If ARG is non-nil, unmark the current line."
 304   (interactive "P")
 305   (let ((inhibit-read-only t)
 306         buffer-read-only
 307         properties)
 308     (beginning-of-line)
 309     (setq properties (text-properties-at (point)))
 310     (delete-char 1)
 311     (insert (if arg " " "*"))
 312     (set-text-properties (1- (point)) (point) properties)
 313     (forward-line)))
 314
 315 (defun epa-unmark (&optional arg)
 316   "Unmark the current line.
 317 If ARG is non-nil, mark the current line."
 318   (interactive "P")
 319   (epa-mark (not arg)))
 320
 321 (defun epa-toggle-mark ()
 322   "Toggle the mark the current line."
 323   (interactive)
 324   (epa-mark (eq (char-after (save-excursion (beginning-of-line) (point))) ?*)))
 325
 326 (defun epa-exit-buffer ()
 327   "Exit the current buffer.
 328 `epa-exit-buffer-function' is called if it is set."
 329   (interactive)
 330   (funcall epa-exit-buffer-function))
 331
 332 (defun epa--insert-keys (context name mode)
 333   (save-excursion
 334     (save-restriction
 335       (narrow-to-region (point) (point))
 336       (let ((keys (epg-list-keys context name mode))
 337             point)
 338         (while keys
 339           (setq point (point))
 340           (insert "  ")
 341           (add-text-properties point (point)
 342                                (list 'epa-key (car keys)
 343                                      'front-sticky nil
 344                                      'rear-nonsticky t
 345                                      'start-open t
 346                                      'end-open t))
 347           (widget-create 'epa-key :value (car keys))
 348           (insert "\n")
 349           (setq keys (cdr keys))))
 350       (add-text-properties (point-min) (point-max)
 351                            (list 'epa-list-keys t
 352                                  'front-sticky nil
 353                                  'rear-nonsticky t
 354                                  'start-open t
 355                                  'end-open t)))))
 356
 357 (defun epa--list-keys (name secret)
 358   (unless (and epa-keys-buffer
 359                (buffer-live-p epa-keys-buffer))
 360     (setq epa-keys-buffer (generate-new-buffer "*Keys*")))
 361   (set-buffer epa-keys-buffer)
 362   (epa-key-list-mode)
 363   (let ((inhibit-read-only t)
 364         buffer-read-only
 365         (point (point-min))
 366         (context (epg-make-context epa-protocol)))
 367     (unless (get-text-property point 'epa-list-keys)
 368       (setq point (next-single-property-change point 'epa-list-keys)))
 369     (when point
 370       (delete-region point
 371                      (or (next-single-property-change point 'epa-list-keys)
 372                          (point-max)))
 373       (goto-char point))
 374     (epa--insert-keys context name secret)
 375     (widget-setup)
 376     (set-keymap-parent (current-local-map) widget-keymap))
 377   (make-local-variable 'epa-list-keys-arguments)
 378   (setq epa-list-keys-arguments (list name secret))
 379   (goto-char (point-min))
 380   (pop-to-buffer (current-buffer)))
 381
 382 ;;;###autoload
 383 (defun epa-list-keys (&optional name)
 384   "List all keys matched with NAME from the public keyring."
 385   (interactive
 386    (if current-prefix-arg
 387        (let ((name (read-string "Pattern: "
 388                                 (if epa-list-keys-arguments
 389                                     (car epa-list-keys-arguments)))))
 390          (list (if (equal name "") nil name)))
 391      (list nil)))
 392   (epa--list-keys name nil))
 393
 394 ;;;###autoload
 395 (defun epa-list-secret-keys (&optional name)
 396   "List all keys matched with NAME from the private keyring."
 397   (interactive
 398    (if current-prefix-arg
 399        (let ((name (read-string "Pattern: "
 400                                 (if epa-list-keys-arguments
 401                                     (car epa-list-keys-arguments)))))
 402          (list (if (equal name "") nil name)))
 403      (list nil)))
 404   (epa--list-keys name t))
 405
 406 (defun epa--key-list-revert-buffer (&optional ignore-auto noconfirm)
 407   (apply #'epa--list-keys epa-list-keys-arguments))
 408
 409 (defun epa--marked-keys ()
 410   (or (save-excursion
 411         (set-buffer epa-keys-buffer)
 412         (goto-char (point-min))
 413         (let (keys key)
 414           (while (re-search-forward "^\\*" nil t)
 415             (if (setq key (get-text-property (match-beginning 0)
 416                                              'epa-key))
 417                 (setq keys (cons key keys))))
 418           (nreverse keys)))
 419       (save-excursion
 420         (beginning-of-line)
 421         (let ((key (get-text-property (point) 'epa-key)))
 422           (if key
 423               (list key))))))
 424
 425 ;;;###autoload
 426 (defun epa-select-keys (context prompt &optional names secret)
 427   "Display a user's keyring and ask him to select keys.
 428 CONTEXT is an epg-context.
 429 PROMPT is a string to prompt with.
 430 NAMES is a list of strings to be matched with keys.  If it is nil, all
 431 the keys are listed.
 432 If SECRET is non-nil, list secret keys instead of public keys."
 433   (save-excursion
 434     (unless (and epa-keys-buffer
 435                  (buffer-live-p epa-keys-buffer))
 436       (setq epa-keys-buffer (generate-new-buffer "*Keys*")))
 437     (set-buffer epa-keys-buffer)
 438     (epa-key-list-mode)
 439     (let ((inhibit-read-only t)
 440           buffer-read-only)
 441       (erase-buffer)
 442       (insert prompt "\n"
 443               (substitute-command-keys "\
 444 - `\\[epa-mark]' to mark a key on the line
 445 - `\\[epa-unmark]' to unmark a key on the line\n"))
 446       (widget-create 'link
 447                      :notify (lambda (&rest ignore) (abort-recursive-edit))
 448                      :help-echo
 449                      (substitute-command-keys
 450                       "Click here or \\[abort-recursive-edit] to cancel")
 451                      "Cancel")
 452       (widget-create 'link
 453                      :notify (lambda (&rest ignore) (exit-recursive-edit))
 454                      :help-echo
 455                      (substitute-command-keys
 456                       "Click here or \\[exit-recursive-edit] to finish")
 457                      "OK")
 458       (insert "\n\n")
 459       (epa--insert-keys context names secret)
 460       (widget-setup)
 461       (set-keymap-parent (current-local-map) widget-keymap)
 462       (setq epa-exit-buffer-function #'abort-recursive-edit)
 463       (goto-char (point-min))
 464       (pop-to-buffer (current-buffer)))
 465     (unwind-protect
 466         (progn
 467           (recursive-edit)
 468           (epa--marked-keys))
 469       (if (get-buffer-window epa-keys-buffer)
 470           (delete-window (get-buffer-window epa-keys-buffer)))
 471       (kill-buffer epa-keys-buffer))))
 472
 473 (defun epa--format-fingerprint-1 (fingerprint unit-size block-size)
 474   (let ((unit 0))
 475     (with-temp-buffer
 476       (insert fingerprint)
 477       (goto-char (point-min))
 478       (while (progn
 479                (goto-char (+ (point) unit-size))
 480                (not (eobp)))
 481         (setq unit (1+ unit))
 482         (insert (if (= (% unit block-size) 0) "  " " ")))
 483       (buffer-string))))
 484
 485 (defun epa--format-fingerprint (fingerprint)
 486   (if fingerprint
 487       (if (= (length fingerprint) 40)
 488           ;; 1234 5678 9ABC DEF0 1234  5678 9ABC DEF0 1234 5678
 489           (epa--format-fingerprint-1 fingerprint 4 5)
 490         ;; 12 34 56 78 9A BC DE F0  12 34 56 78 9A BC DE F0
 491         (epa--format-fingerprint-1 fingerprint 2 8))))
 492
 493 (defun epa--show-key (key)
 494   (let* ((primary-sub-key (car (epg-key-sub-key-list key)))
 495          (entry (assoc (epg-sub-key-id primary-sub-key)
 496                        epa-key-buffer-alist))
 497          (inhibit-read-only t)
 498          buffer-read-only
 499          pointer)
 500     (unless entry
 501       (setq entry (cons (epg-sub-key-id primary-sub-key) nil)
 502             epa-key-buffer-alist (cons entry epa-key-buffer-alist)))
 503     (unless (and (cdr entry)
 504                  (buffer-live-p (cdr entry)))
 505       (setcdr entry (generate-new-buffer
 506                      (format "*Key*%s" (epg-sub-key-id primary-sub-key)))))
 507     (set-buffer (cdr entry))
 508     (epa-key-mode)
 509     (make-local-variable 'epa-key)
 510     (setq epa-key key)
 511     (erase-buffer)
 512     (setq pointer (epg-key-user-id-list key))
 513     (while pointer
 514       (if (car pointer)
 515           (insert " "
 516                   (if (epg-user-id-validity (car pointer))
 517                       (char-to-string
 518                        (car (rassq (epg-user-id-validity (car pointer))
 519                                    epg-key-validity-alist)))
 520                     " ")
 521                   " "
 522                   (if (stringp (epg-user-id-string (car pointer)))
 523                       (epg-user-id-string (car pointer))
 524                     (epg-decode-dn (epg-user-id-string (car pointer))))
 525                   "\n"))
 526       (setq pointer (cdr pointer)))
 527     (setq pointer (epg-key-sub-key-list key))
 528     (while pointer
 529       (insert " "
 530               (if (epg-sub-key-validity (car pointer))
 531                   (char-to-string
 532                    (car (rassq (epg-sub-key-validity (car pointer))
 533                                epg-key-validity-alist)))
 534                 " ")
 535               " "
 536               (epg-sub-key-id (car pointer))
 537               " "
 538               (format "%dbits"
 539                       (epg-sub-key-length (car pointer)))
 540               " "
 541               (cdr (assq (epg-sub-key-algorithm (car pointer))
 542                          epg-pubkey-algorithm-alist))
 543               "\n\tCreated: "
 544               (format-time-string "%Y-%m-%d"
 545                                   (epg-sub-key-creation-time (car pointer)))
 546               (if (epg-sub-key-expiration-time (car pointer))
 547                   (format "\n\tExpires: %s"
 548                           (format-time-string "%Y-%m-%d"
 549                                               (epg-sub-key-expiration-time
 550                                                (car pointer))))
 551                 "")
 552               "\n\tCapabilities: "
 553               (mapconcat #'symbol-name
 554                          (epg-sub-key-capability (car pointer))
 555                          " ")
 556               "\n\tFingerprint: "
 557               (epa--format-fingerprint (epg-sub-key-fingerprint (car pointer)))
 558               "\n")
 559       (setq pointer (cdr pointer)))
 560     (goto-char (point-min))
 561     (pop-to-buffer (current-buffer))))
 562
 563 (defun epa-display-info (info)
 564   (if epa-popup-info-window
 565       (save-selected-window
 566         (unless (and epa-info-buffer (buffer-live-p epa-info-buffer))
 567           (setq epa-info-buffer (generate-new-buffer "*Info*")))
 568         (if (get-buffer-window epa-info-buffer)
 569             (delete-window (get-buffer-window epa-info-buffer)))
 570         (save-excursion
 571           (set-buffer epa-info-buffer)
 572           (let ((inhibit-read-only t)
 573                 buffer-read-only)
 574             (erase-buffer)
 575             (insert info))
 576           (epa-info-mode)
 577           (goto-char (point-min)))
 578         (if (> (window-height)
 579                epa-info-window-height)
 580             (set-window-buffer (split-window nil (- (window-height)
 581                                                     epa-info-window-height))
 582                                epa-info-buffer)
 583           (pop-to-buffer epa-info-buffer)
 584           (if (> (window-height) epa-info-window-height)
 585               (shrink-window (- (window-height) epa-info-window-height)))))
 586     (message "%s" info)))
 587
 588 (defun epa-display-verify-result (verify-result)
 589   (epa-display-info (epg-verify-result-to-string verify-result)))
 590 (make-obsolete 'epa-display-verify-result 'epa-display-info)
 591
 592 (defun epa-passphrase-callback-function (context key-id handback)
 593   (if (eq key-id 'SYM)
 594       (read-passwd "Passphrase for symmetric encryption: "
 595                    (eq (epg-context-operation context) 'encrypt))
 596     (read-passwd
 597      (if (eq key-id 'PIN)
 598         "Passphrase for PIN: "
 599        (let ((entry (assoc key-id epg-user-id-alist)))
 600          (if entry
 601              (format "Passphrase for %s %s: " key-id (cdr entry))
 602            (format "Passphrase for %s: " key-id)))))))
 603
 604 (defun epa-progress-callback-function (context what char current total
 605                                                handback)
 606   (message "%s%d%% (%d/%d)" (or handback
 607                                 (concat what ": "))
 608            (if (> total 0) (floor (* (/ current (float total)) 100)) 0)
 609            current total))
 610
 611 ;;;###autoload
 612 (defun epa-decrypt-file (file)
 613   "Decrypt FILE."
 614   (interactive "fFile: ")
 615   (setq file (expand-file-name file))
 616   (let* ((default-name (file-name-sans-extension file))
 617          (plain (expand-file-name
 618                  (read-file-name
 619                   (concat "To file (default "
 620                           (file-name-nondirectory default-name)
 621                           ") ")
 622                   (file-name-directory default-name)
 623                   default-name)))
 624          (context (epg-make-context epa-protocol)))
 625     (epg-context-set-passphrase-callback context
 626                                          #'epa-passphrase-callback-function)
 627     (epg-context-set-progress-callback context
 628                                        #'epa-progress-callback-function
 629                                        (format "Decrypting %s..."
 630                                                (file-name-nondirectory file)))
 631     (message "Decrypting %s..." (file-name-nondirectory file))
 632     (epg-decrypt-file context file plain)
 633     (message "Decrypting %s...wrote %s" (file-name-nondirectory file)
 634              (file-name-nondirectory plain))
 635     (if (epg-context-result-for context 'verify)
 636         (epa-display-info (epg-verify-result-to-string
 637                            (epg-context-result-for context 'verify))))))
 638
 639 ;;;###autoload
 640 (defun epa-verify-file (file)
 641   "Verify FILE."
 642   (interactive "fFile: ")
 643   (setq file (expand-file-name file))
 644   (let* ((context (epg-make-context epa-protocol))
 645          (plain (if (equal (file-name-extension file) "sig")
 646                     (file-name-sans-extension file))))
 647     (epg-context-set-progress-callback context
 648                                        #'epa-progress-callback-function
 649                                        (format "Verifying %s..."
 650                                                (file-name-nondirectory file)))
 651     (message "Verifying %s..." (file-name-nondirectory file))
 652     (epg-verify-file context file plain)
 653     (message "Verifying %s...done" (file-name-nondirectory file))
 654     (if (epg-context-result-for context 'verify)
 655         (epa-display-info (epg-verify-result-to-string
 656                            (epg-context-result-for context 'verify))))))
 657
 658 (defun epa--read-signature-type ()
 659   (let (type c)
 660     (while (null type)
 661       (message "Signature type (n,c,d,?) ")
 662       (setq c (read-char))
 663       (cond ((eq c ?c)
 664              (setq type 'clear))
 665             ((eq c ?d)
 666              (setq type 'detached))
 667             ((eq c ??)
 668              (with-output-to-temp-buffer "*Help*"
 669                (save-excursion
 670                  (set-buffer standard-output)
 671                  (insert "\
 672 n - Create a normal signature
 673 c - Create a cleartext signature
 674 d - Create a detached signature
 675 ? - Show this help
 676 "))))
 677             (t
 678              (setq type 'normal))))))
 679
 680 ;;;###autoload
 681 (defun epa-sign-file (file signers mode)
 682   "Sign FILE by SIGNERS keys selected."
 683   (interactive
 684    (let ((verbose current-prefix-arg))
 685      (list (expand-file-name (read-file-name "File: "))
 686            (if verbose
 687                (epa-select-keys (epg-make-context epa-protocol)
 688                                 "Select keys for signing.
 689 If no one is selected, default secret key is used.  "
 690                                 nil t))
 691            (if verbose
 692                (epa--read-signature-type)
 693              'clear))))
 694   (let ((signature (concat file
 695                            (if (eq epa-protocol 'OpenPGP)
 696                                (if (or epa-armor
 697                                        (not (memq mode
 698                                                   '(nil t normal detached))))
 699                                    ".asc"
 700                                  (if (memq mode '(t detached))
 701                                      ".sig"
 702                                    ".gpg"))
 703                              (if (memq mode '(t detached))
 704                                  ".p7s"
 705                                ".p7m"))))
 706         (context (epg-make-context epa-protocol)))
 707     (epg-context-set-armor context epa-armor)
 708     (epg-context-set-textmode context epa-textmode)
 709     (epg-context-set-signers context signers)
 710     (epg-context-set-passphrase-callback context
 711                                          #'epa-passphrase-callback-function)
 712     (epg-context-set-progress-callback context
 713                                        #'epa-progress-callback-function
 714                                        (format "Signing %s..."
 715                                                (file-name-nondirectory file)))
 716     (message "Signing %s..." (file-name-nondirectory file))
 717     (epg-sign-file context file signature mode)
 718     (message "Signing %s...wrote %s" (file-name-nondirectory file)
 719              (file-name-nondirectory signature))))
 720
 721 ;;;###autoload
 722 (defun epa-encrypt-file (file recipients)
 723   "Encrypt FILE for RECIPIENTS."
 724   (interactive
 725    (list (expand-file-name (read-file-name "File: "))
 726          (epa-select-keys (epg-make-context epa-protocol)
 727                           "Select recipients for encryption.
 728 If no one is selected, symmetric encryption will be performed.  ")))
 729   (let ((cipher (concat file (if (eq epa-protocol 'OpenPGP)
 730                                  (if epa-armor ".asc" ".gpg")
 731                                ".p7m")))
 732         (context (epg-make-context epa-protocol)))
 733     (epg-context-set-armor context epa-armor)
 734     (epg-context-set-textmode context epa-textmode)
 735     (epg-context-set-passphrase-callback context
 736                                          #'epa-passphrase-callback-function)
 737     (epg-context-set-progress-callback context
 738                                        #'epa-progress-callback-function
 739                                        (format "Encrypting %s..."
 740                                                (file-name-nondirectory file)))
 741     (message "Encrypting %s..." (file-name-nondirectory file))
 742     (epg-encrypt-file context file recipients cipher)
 743     (message "Encrypting %s...wrote %s" (file-name-nondirectory file)
 744              (file-name-nondirectory cipher))))
 745
 746 ;;;###autoload
 747 (defun epa-decrypt-region (start end)
 748   "Decrypt the current region between START and END.
 749
 750 Don't use this command in Lisp programs!"
 751   (interactive "r")
 752   (save-excursion
 753     (let ((context (epg-make-context epa-protocol))
 754           plain)
 755       (epg-context-set-passphrase-callback context
 756                                            #'epa-passphrase-callback-function)
 757       (epg-context-set-progress-callback context
 758                                          #'epa-progress-callback-function
 759                                          "Decrypting...")
 760       (message "Decrypting...")
 761       (setq plain (epg-decrypt-string context (buffer-substring start end)))
 762       (message "Decrypting...done")
 763       (setq plain (epa--decode-coding-string
 764                    plain
 765                    (or coding-system-for-read
 766                        (get-text-property start 'epa-coding-system-used))))
 767       (if (y-or-n-p "Replace the original text? ")
 768           (let ((inhibit-read-only t)
 769                 buffer-read-only)
 770             (delete-region start end)
 771             (goto-char start)
 772             (insert plain))
 773         (with-output-to-temp-buffer "*Temp*"
 774           (set-buffer standard-output)
 775           (insert plain)
 776           (epa-info-mode)))
 777       (if (epg-context-result-for context 'verify)
 778           (epa-display-info (epg-verify-result-to-string
 779                              (epg-context-result-for context 'verify)))))))
 780
 781 (defun epa--find-coding-system-for-mime-charset (mime-charset)
 782   (if (featurep 'xemacs)
 783       (if (fboundp 'find-coding-system)
 784           (find-coding-system mime-charset))
 785     (let ((pointer (coding-system-list)))
 786       (while (and pointer
 787                   (eq (coding-system-get (car pointer) 'mime-charset)
 788                       mime-charset))
 789         (setq pointer (cdr pointer)))
 790       pointer)))
 791
 792 ;;;###autoload
 793 (defun epa-decrypt-armor-in-region (start end)
 794   "Decrypt OpenPGP armors in the current region between START and END.
 795
 796 Don't use this command in Lisp programs!"
 797   (interactive "r")
 798   (save-excursion
 799     (save-restriction
 800       (narrow-to-region start end)
 801       (goto-char start)
 802       (let (armor-start armor-end)
 803         (while (re-search-forward "-----BEGIN PGP MESSAGE-----$" nil t)
 804           (setq armor-start (match-beginning 0)
 805                 armor-end (re-search-forward "^-----END PGP MESSAGE-----$"
 806                                              nil t))
 807           (unless armor-end
 808             (error "No armor tail"))
 809           (goto-char armor-start)
 810           (let ((coding-system-for-read
 811                  (or coding-system-for-read
 812                      (if (re-search-forward "^Charset: \\(.*\\)" armor-end t)
 813                          (epa--find-coding-system-for-mime-charset
 814                           (intern (downcase (match-string 1))))))))
 815             (goto-char armor-end)
 816             (epa-decrypt-region armor-start armor-end)))))))
 817
 818 ;;;###autoload
 819 (defun epa-verify-region (start end)
 820   "Verify the current region between START and END.
 821
 822 Don't use this command in Lisp programs!"
 823   (interactive "r")
 824   (let ((context (epg-make-context epa-protocol))
 825         plain)
 826     (epg-context-set-progress-callback context
 827                                        #'epa-progress-callback-function
 828                                        "Verifying...")
 829     (setq plain (epg-verify-string
 830                  context
 831                  (epa--encode-coding-string
 832                   (buffer-substring start end)
 833                   (or coding-system-for-write
 834                       (get-text-property start
 835                                          'epa-coding-system-used)))))
 836     (if (y-or-n-p "Replace the original text? ")
 837         (let ((inhibit-read-only t)
 838               buffer-read-only)
 839           (delete-region start end)
 840           (goto-char start)
 841           (insert plain))
 842         (with-output-to-temp-buffer "*Temp*"
 843           (set-buffer standard-output)
 844           (insert plain)
 845           (epa-info-mode)))
 846     (if (epg-context-result-for context 'verify)
 847         (epa-display-info (epg-verify-result-to-string
 848                            (epg-context-result-for context 'verify))))))
 849
 850 ;;;###autoload
 851 (defun epa-verify-cleartext-in-region (start end)
 852   "Verify OpenPGP cleartext signed messages in the current region
 853 between START and END.
 854
 855 Don't use this command in Lisp programs!"
 856   (interactive "r")
 857   (save-excursion
 858     (save-restriction
 859       (narrow-to-region start end)
 860       (goto-char start)
 861       (let (cleartext-start cleartext-end)
 862         (while (re-search-forward "-----BEGIN PGP SIGNED MESSAGE-----$"
 863                                   nil t)
 864           (setq cleartext-start (match-beginning 0))
 865           (unless (re-search-forward "^-----BEGIN PGP SIGNATURE-----$"
 866                                            nil t)
 867             (error "Invalid cleartext signed message"))
 868           (setq cleartext-end (re-search-forward
 869                            "^-----END PGP SIGNATURE-----$"
 870                            nil t))
 871           (unless cleartext-end
 872             (error "No cleartext tail"))
 873           (epa-verify-region cleartext-start cleartext-end))))))
 874
 875 (if (fboundp 'select-safe-coding-system)
 876     (defalias 'epa--select-safe-coding-system 'select-safe-coding-system)
 877   (defun epa--select-safe-coding-system (from to)
 878     buffer-file-coding-system))
 879
 880 ;;;###autoload
 881 (defun epa-sign-region (start end signers mode)
 882   "Sign the current region between START and END by SIGNERS keys selected.
 883
 884 Don't use this command in Lisp programs!"
 885   (interactive
 886    (let ((verbose current-prefix-arg))
 887      (setq epa-last-coding-system-specified
 888            (or coding-system-for-write
 889                (epa--select-safe-coding-system
 890                 (region-beginning) (region-end))))
 891      (list (region-beginning) (region-end)
 892            (if verbose
 893                (epa-select-keys (epg-make-context epa-protocol)
 894                                 "Select keys for signing.
 895 If no one is selected, default secret key is used.  "
 896                                 nil t))
 897            (if verbose
 898                (epa--read-signature-type)
 899              'clear))))
 900   (save-excursion
 901     (let ((context (epg-make-context epa-protocol))
 902           signature)
 903       ;;(epg-context-set-armor context epa-armor)
 904       (epg-context-set-armor context t)
 905       ;;(epg-context-set-textmode context epa-textmode)
 906       (epg-context-set-textmode context t)
 907       (epg-context-set-signers context signers)
 908       (epg-context-set-passphrase-callback context
 909                                            #'epa-passphrase-callback-function)
 910       (epg-context-set-progress-callback context
 911                                          #'epa-progress-callback-function
 912                                          "Signing...")
 913       (message "Signing...")
 914       (setq signature (epg-sign-string context
 915                                        (epa--encode-coding-string
 916                                         (buffer-substring start end)
 917                                         epa-last-coding-system-specified)
 918                                        mode))
 919       (message "Signing...done")
 920       (delete-region start end)
 921       (goto-char start)
 922       (add-text-properties (point)
 923                            (progn
 924                              (insert (epa--decode-coding-string
 925                                       signature
 926                                       (or coding-system-for-read
 927                                           epa-last-coding-system-specified)))
 928                              (point))
 929                            (list 'epa-coding-system-used
 930                                  epa-last-coding-system-specified
 931                                  'front-sticky nil
 932                                  'rear-nonsticky t
 933                                  'start-open t
 934                                  'end-open t)))))
 935
 936 (if (fboundp 'derived-mode-p)
 937     (defalias 'epa--derived-mode-p 'derived-mode-p)
 938   (defun epa--derived-mode-p (&rest modes)
 939     "Non-nil if the current major mode is derived from one of MODES.
 940 Uses the `derived-mode-parent' property of the symbol to trace backwards."
 941     (let ((parent major-mode))
 942       (while (and (not (memq parent modes))
 943                   (setq parent (get parent 'derived-mode-parent))))
 944       parent)))
 945
 946 ;;;###autoload
 947 (defun epa-encrypt-region (start end recipients sign signers)
 948   "Encrypt the current region between START and END for RECIPIENTS.
 949
 950 Don't use this command in Lisp programs!"
 951   (interactive
 952    (let ((verbose current-prefix-arg)
 953          (context (epg-make-context epa-protocol))
 954          sign)
 955      (setq epa-last-coding-system-specified
 956            (or coding-system-for-write
 957                (epa--select-safe-coding-system
 958                 (region-beginning) (region-end))))
 959      (list (region-beginning) (region-end)
 960            (epa-select-keys context
 961                             "Select recipients for encryption.
 962 If no one is selected, symmetric encryption will be performed.  ")
 963            (setq sign (if verbose (y-or-n-p "Sign? ")))
 964            (if sign
 965                (epa-select-keys context
 966                                 "Select keys for signing.  ")))))
 967   (save-excursion
 968     (let ((context (epg-make-context epa-protocol))
 969           cipher)
 970       ;;(epg-context-set-armor context epa-armor)
 971       (epg-context-set-armor context t)
 972       ;;(epg-context-set-textmode context epa-textmode)
 973       (epg-context-set-textmode context t)
 974       (if sign
 975           (epg-context-set-signers context signers))
 976       (epg-context-set-passphrase-callback context
 977                                            #'epa-passphrase-callback-function)
 978       (epg-context-set-progress-callback context
 979                                          #'epa-progress-callback-function
 980                                          "Encrypting...")
 981       (message "Encrypting...")
 982       (setq cipher (epg-encrypt-string context
 983                                        (epa--encode-coding-string
 984                                         (buffer-substring start end)
 985                                         epa-last-coding-system-specified)
 986                                        recipients
 987                                        sign))
 988       (message "Encrypting...done")
 989       (delete-region start end)
 990       (goto-char start)
 991       (add-text-properties (point)
 992                            (progn
 993                              (insert cipher)
 994                              (point))
 995                            (list 'epa-coding-system-used
 996                                  epa-last-coding-system-specified
 997                                  'front-sticky nil
 998                                  'rear-nonsticky t
 999                                  'start-open t
1000                                  'end-open t)))))
1001
1002 ;;;###autoload
1003 (defun epa-delete-keys (keys &optional allow-secret)
1004   "Delete selected KEYS.
1005
1006 Don't use this command in Lisp programs!"
1007   (interactive
1008    (let ((keys (epa--marked-keys)))
1009      (unless keys
1010        (error "No keys selected"))
1011      (list keys
1012            (eq (nth 1 epa-list-keys-arguments) t))))
1013   (let ((context (epg-make-context epa-protocol)))
1014     (message "Deleting...")
1015     (epg-delete-keys context keys allow-secret)
1016     (message "Deleting...done")
1017     (apply #'epa-list-keys epa-list-keys-arguments)))
1018
1019 ;;;###autoload
1020 (defun epa-import-keys (file)
1021   "Import keys from FILE.
1022
1023 Don't use this command in Lisp programs!"
1024   (interactive "fFile: ")
1025   (setq file (expand-file-name file))
1026   (let ((context (epg-make-context epa-protocol)))
1027     (message "Importing %s..." (file-name-nondirectory file))
1028     (condition-case nil
1029         (progn
1030           (epg-import-keys-from-file context file)
1031           (message "Importing %s...done" (file-name-nondirectory file)))
1032       (error
1033        (message "Importing %s...failed" (file-name-nondirectory file))))
1034     (if (epg-context-result-for context 'import)
1035         (epa-display-info (epg-import-result-to-string
1036                            (epg-context-result-for context 'import))))
1037     (if (eq major-mode 'epa-key-list-mode)
1038         (apply #'epa-list-keys epa-list-keys-arguments))))
1039
1040 ;;;###autoload
1041 (defun epa-import-keys-region (start end)
1042   "Import keys from the region.
1043
1044 Don't use this command in Lisp programs!"
1045   (interactive "r")
1046   (let ((context (epg-make-context epa-protocol)))
1047     (message "Importing...")
1048     (condition-case nil
1049         (progn
1050           (epg-import-keys-from-string context (buffer-substring start end))
1051           (message "Importing...done"))
1052       (error
1053        (message "Importing...failed")))
1054     (if (epg-context-result-for context 'import)
1055         (epa-display-info (epg-import-result-to-string
1056                            (epg-context-result-for context 'import))))))
1057
1058 ;;;###autoload
1059 (defun epa-import-armor-in-region (start end)
1060   "Import keys in the OpenPGP armor format in the current region
1061 between START and END.
1062
1063 Don't use this command in Lisp programs!"
1064   (interactive "r")
1065   (save-excursion
1066     (save-restriction
1067       (narrow-to-region start end)
1068       (goto-char start)
1069       (let (armor-start armor-end)
1070         (while (re-search-forward
1071                 "-----BEGIN \\(PGP \\(PUBLIC\\|PRIVATE\\) KEY BLOCK\\)-----$"
1072                 nil t)
1073           (setq armor-start (match-beginning 0)
1074                 armor-end (re-search-forward
1075                            (concat "^-----END " (match-string 1) "-----$")
1076                            nil t))
1077           (unless armor-end
1078             (error "No armor tail"))
1079           (epa-import-keys-region armor-start armor-end))))))
1080
1081 ;;;###autoload
1082 (defun epa-export-keys (keys file)
1083   "Export selected KEYS to FILE.
1084
1085 Don't use this command in Lisp programs!"
1086   (interactive
1087    (let ((keys (epa--marked-keys))
1088          default-name)
1089      (unless keys
1090        (error "No keys selected"))
1091      (setq default-name
1092            (expand-file-name
1093             (concat (epg-sub-key-id (car (epg-key-sub-key-list (car keys))))
1094                     (if epa-armor ".asc" ".gpg"))
1095             default-directory))
1096      (list keys
1097            (expand-file-name
1098             (read-file-name
1099              (concat "To file (default "
1100                      (file-name-nondirectory default-name)
1101                      ") ")
1102              (file-name-directory default-name)
1103              default-name)))))
1104   (let ((context (epg-make-context epa-protocol)))
1105     (epg-context-set-armor context epa-armor)
1106     (message "Exporting to %s..." (file-name-nondirectory file))
1107     (epg-export-keys-to-file context keys file)
1108     (message "Exporting to %s...done" (file-name-nondirectory file))))
1109
1110 ;;;###autoload
1111 (defun epa-insert-keys (keys)
1112   "Insert selected KEYS after the point.
1113
1114 Don't use this command in Lisp programs!"
1115   (interactive
1116    (list (epa-select-keys (epg-make-context epa-protocol)
1117                           "Select keys to export.  ")))
1118   (let ((context (epg-make-context epa-protocol)))
1119     ;;(epg-context-set-armor context epa-armor)
1120     (epg-context-set-armor context t)
1121     (insert (epg-export-keys-to-string context keys))))
1122
1123 ;;;###autoload
1124 (defun epa-sign-keys (keys &optional local)
1125   "Sign selected KEYS.
1126 If a prefix-arg is specified, the signature is marked as non exportable.
1127
1128 Don't use this command in Lisp programs!"
1129   (interactive
1130    (let ((keys (epa--marked-keys)))
1131      (unless keys
1132        (error "No keys selected"))
1133      (list keys current-prefix-arg)))
1134   (let ((context (epg-make-context epa-protocol)))
1135     (epg-context-set-passphrase-callback context
1136                                          #'epa-passphrase-callback-function)
1137     (epg-context-set-progress-callback context
1138                                        #'epa-progress-callback-function
1139                                        "Signing keys...")
1140     (message "Signing keys...")
1141     (epg-sign-keys context keys local)
1142     (message "Signing keys...done")))
1143 (make-obsolete 'epa-sign-keys "Do not use.")
1144
1145 (provide 'epa)
1146
1147 ;;; epa.el ends here