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