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