code.delx.au - gnu-emacs/blob - lisp/epg.el

   1 ;;; epg.el --- the EasyPG Library -*- lexical-binding: t -*-
   2 ;; Copyright (C) 1999-2000, 2002-2016 Free Software Foundation, Inc.
   3
   4 ;; Author: Daiki Ueno <ueno@unixuser.org>
   5 ;; Keywords: PGP, GnuPG
   6 ;; Version: 1.0.0
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Code:
  24
  25 (require 'epg-config)
  26 (eval-when-compile (require 'cl-lib))
  27
  28 (defvar epg-user-id nil
  29   "GnuPG ID of your default identity.")
  30
  31 (defvar epg-user-id-alist nil
  32   "An alist mapping from key ID to user ID.")
  33
  34 (defvar epg-last-status nil)
  35 (defvar epg-read-point nil)
  36 (defvar epg-process-filter-running nil)
  37 (defvar epg-pending-status-list nil)
  38 (defvar epg-key-id nil)
  39 (defvar epg-context nil)
  40 (defvar epg-debug-buffer nil)
  41 (defvar epg-agent-file nil)
  42 (defvar epg-agent-mtime nil)
  43
  44 ;; from gnupg/include/cipher.h
  45 (defconst epg-cipher-algorithm-alist
  46   '((0 . "NONE")
  47     (1 . "IDEA")
  48     (2 . "3DES")
  49     (3 . "CAST5")
  50     (4 . "BLOWFISH")
  51     (7 . "AES")
  52     (8 . "AES192")
  53     (9 . "AES256")
  54     (10 . "TWOFISH")
  55     (11 . "CAMELLIA128")
  56     (12 . "CAMELLIA256")
  57     (110 . "DUMMY")))
  58
  59 ;; from gnupg/include/cipher.h
  60 (defconst epg-pubkey-algorithm-alist
  61   '((1 . "RSA")
  62     (2 . "RSA_E")
  63     (3 . "RSA_S")
  64     (16 . "ELGAMAL_E")
  65     (17 . "DSA")
  66     (20 . "ELGAMAL")))
  67
  68 ;; from gnupg/include/cipher.h
  69 (defconst epg-digest-algorithm-alist
  70   '((1 . "MD5")
  71     (2 . "SHA1")
  72     (3 . "RIPEMD160")
  73     (8 . "SHA256")
  74     (9 . "SHA384")
  75     (10 . "SHA512")
  76     (11 . "SHA224")))
  77
  78 ;; from gnupg/include/cipher.h
  79 (defconst epg-compress-algorithm-alist
  80   '((0 . "NONE")
  81     (1 . "ZIP")
  82     (2 . "ZLIB")
  83     (3 . "BZIP2")))
  84
  85 (defconst epg-invalid-recipients-reason-alist
  86   '((0 . "No specific reason given")
  87     (1 . "Not Found")
  88     (2 . "Ambiguous specification")
  89     (3 . "Wrong key usage")
  90     (4 . "Key revoked")
  91     (5 . "Key expired")
  92     (6 . "No CRL known")
  93     (7 . "CRL too old")
  94     (8 . "Policy mismatch")
  95     (9 . "Not a secret key")
  96     (10 . "Key not trusted")))
  97
  98 (defconst epg-delete-problem-reason-alist
  99   '((1 . "No such key")
 100     (2 . "Must delete secret key first")
 101     (3 . "Ambiguous specification")))
 102
 103 (defconst epg-import-ok-reason-alist
 104   '((0 . "Not actually changed")
 105     (1 . "Entirely new key")
 106     (2 . "New user IDs")
 107     (4 . "New signatures")
 108     (8 . "New subkeys")
 109     (16 . "Contains private key")))
 110
 111 (defconst epg-import-problem-reason-alist
 112   '((0 . "No specific reason given")
 113     (1 . "Invalid Certificate")
 114     (2 . "Issuer Certificate missing")
 115     (3 . "Certificate Chain too long")
 116     (4 . "Error storing certificate")))
 117
 118 (defconst epg-no-data-reason-alist
 119   '((1 . "No armored data")
 120     (2 . "Expected a packet but did not found one")
 121     (3 . "Invalid packet found, this may indicate a non OpenPGP message")
 122     (4 . "Signature expected but not found")))
 123
 124 (defconst epg-unexpected-reason-alist nil)
 125
 126 (defvar epg-key-validity-alist
 127   '((?o . unknown)
 128     (?i . invalid)
 129     (?d . disabled)
 130     (?r . revoked)
 131     (?e . expired)
 132     (?- . none)
 133     (?q . undefined)
 134     (?n . never)
 135     (?m . marginal)
 136     (?f . full)
 137     (?u . ultimate)))
 138
 139 (defvar epg-key-capability-alist
 140   '((?e . encrypt)
 141     (?s . sign)
 142     (?c . certify)
 143     (?a . authentication)
 144     (?D . disabled)))
 145
 146 (defvar epg-new-signature-type-alist
 147   '((?D . detached)
 148     (?C . clear)
 149     (?S . normal)))
 150
 151 (defvar epg-dn-type-alist
 152   '(("1.2.840.113549.1.9.1" . "EMail")
 153     ("2.5.4.12" . "T")
 154     ("2.5.4.42" . "GN")
 155     ("2.5.4.4" . "SN")
 156     ("0.2.262.1.10.7.20" . "NameDistinguisher")
 157     ("2.5.4.16" . "ADDR")
 158     ("2.5.4.15" . "BC")
 159     ("2.5.4.13" . "D")
 160     ("2.5.4.17" . "PostalCode")
 161     ("2.5.4.65" . "Pseudo")
 162     ("2.5.4.5" . "SerialNumber")))
 163
 164 (defvar epg-prompt-alist nil)
 165
 166 (define-error 'epg-error "GPG error")
 167
 168 (cl-defstruct (epg-data
 169                (:constructor nil)
 170                (:constructor epg-make-data-from-file (file))
 171                (:constructor epg-make-data-from-string (string))
 172                (:copier nil)
 173                (:predicate nil))
 174   (file nil :read-only t)
 175   (string nil :read-only t))
 176
 177 (defmacro epg--gv-nreverse (place)
 178   (gv-letplace (getter setter) place
 179     (funcall setter `(nreverse ,getter))))
 180
 181 (cl-defstruct (epg-context
 182                (:constructor nil)
 183                (:constructor epg-context--make
 184                 (protocol &optional armor textmode include-certs
 185                           cipher-algorithm digest-algorithm
 186                           compress-algorithm
 187                  &aux
 188                  (program
 189                   (pcase protocol
 190                     (`OpenPGP epg-gpg-program)
 191                     (`CMS epg-gpgsm-program)
 192                     (_ (signal 'epg-error
 193                                (list "unknown protocol" protocol)))))))
 194                (:copier nil)
 195                (:predicate nil))
 196   protocol
 197   program
 198   (home-directory epg-gpg-home-directory)
 199   armor
 200   textmode
 201   include-certs
 202   cipher-algorithm
 203   digest-algorithm
 204   compress-algorithm
 205   (passphrase-callback (list #'epg-passphrase-callback-function))
 206   progress-callback
 207   edit-callback
 208   signers
 209   sig-notations
 210   process
 211   output-file
 212   result
 213   operation
 214   pinentry-mode
 215   (error-output "")
 216   error-buffer)
 217
 218 ;; This is not an alias, just so we can mark it as autoloaded.
 219 ;;;###autoload
 220 (defun epg-make-context (&optional protocol armor textmode include-certs
 221                                    cipher-algorithm digest-algorithm
 222                                    compress-algorithm)
 223   "Return a context object."
 224   (epg-context--make (or protocol 'OpenPGP)
 225                      armor textmode include-certs
 226                      cipher-algorithm digest-algorithm
 227                      compress-algorithm))
 228
 229 (defun epg-context-set-armor (context armor)
 230   "Specify if the output should be ASCII armored in CONTEXT."
 231   (declare (obsolete setf "25.1"))
 232   (setf (epg-context-armor context) armor))
 233
 234 (defun epg-context-set-textmode (context textmode)
 235   "Specify if canonical text mode should be used in CONTEXT."
 236   (declare (obsolete setf "25.1"))
 237   (setf (epg-context-textmode context) textmode))
 238
 239 (defun epg-context-set-passphrase-callback (context
 240                                             passphrase-callback)
 241   "Set the function used to query passphrase.
 242
 243 PASSPHRASE-CALLBACK is either a function, or a cons-cell whose
 244 car is a function and cdr is a callback data.
 245
 246 The function gets three arguments: the context, the key-id in
 247 question, and the callback data (if any).
 248
 249 The callback may not be called if you use GnuPG 2.x, which relies
 250 on the external program called `gpg-agent' for passphrase query.
 251 If you really want to intercept passphrase query, consider
 252 installing GnuPG 1.x _along with_ GnuPG 2.x, which does passphrase
 253 query by itself and Emacs can intercept them."
 254   ;; (declare (obsolete setf "25.1"))
 255   (setf (epg-context-passphrase-callback context)
 256         (if (functionp passphrase-callback)
 257             (list passphrase-callback)
 258           passphrase-callback)))
 259
 260 (defun epg-context-set-progress-callback (context
 261                                           progress-callback)
 262   "Set the function which handles progress update.
 263
 264 PROGRESS-CALLBACK is either a function, or a cons-cell whose
 265 car is a function and cdr is a callback data.
 266
 267 The function gets six arguments: the context, the operation
 268 description, the character to display a progress unit, the
 269 current amount done, the total amount to be done, and the
 270 callback data (if any)."
 271   (setf (epg-context-progress-callback context)
 272         (if (functionp progress-callback)
 273             (list progress-callback)
 274           progress-callback)))
 275
 276 (defun epg-context-set-signers (context signers)
 277   "Set the list of key-id for signing."
 278   (declare (obsolete setf "25.1"))
 279   (setf (epg-context-signers context) signers))
 280
 281 (cl-defstruct (epg-signature
 282                (:constructor nil)
 283                (:constructor epg-make-signature
 284                 (status &optional key-id))
 285                (:copier nil)
 286                (:predicate nil))
 287   status
 288   key-id
 289   validity
 290   fingerprint
 291   creation-time
 292   expiration-time
 293   pubkey-algorithm
 294   digest-algorithm
 295   class
 296   version
 297   notations)
 298
 299 (cl-defstruct (epg-new-signature
 300                (:constructor nil)
 301                (:constructor epg-make-new-signature
 302                 (type pubkey-algorithm digest-algorithm
 303                       class creation-time fingerprint))
 304                (:copier nil)
 305                (:predicate nil))
 306   (type nil :read-only t)
 307   (pubkey-algorithm nil :read-only t)
 308   (digest-algorithm nil :read-only t)
 309   (class nil :read-only t)
 310   (creation-time nil :read-only t)
 311   (fingerprint nil :read-only t))
 312
 313 (cl-defstruct (epg-key
 314                (:constructor nil)
 315                (:constructor epg-make-key (owner-trust))
 316                (:copier nil)
 317                (:predicate nil))
 318   (owner-trust nil :read-only t)
 319   sub-key-list user-id-list)
 320
 321 (cl-defstruct (epg-sub-key
 322                (:constructor nil)
 323                (:constructor epg-make-sub-key
 324                 (validity capability secret-p algorithm length id
 325                           creation-time expiration-time))
 326                (:copier nil)
 327                (:predicate nil))
 328   validity capability secret-p algorithm length id
 329   creation-time expiration-time fingerprint)
 330
 331 (cl-defstruct (epg-user-id
 332                (:constructor nil)
 333                (:constructor epg-make-user-id (validity string))
 334                (:copier nil)
 335                (:predicate nil))
 336   validity string signature-list)
 337
 338 (cl-defstruct (epg-key-signature
 339                (:constructor nil)
 340                (:constructor epg-make-key-signature
 341                 (validity pubkey-algorithm key-id creation-time
 342                           expiration-time user-id class
 343                           exportable-p))
 344                (:copier nil)
 345                (:predicate nil))
 346   validity pubkey-algorithm key-id creation-time
 347   expiration-time user-id class
 348   exportable-p)
 349
 350 (cl-defstruct (epg-sig-notation
 351                (:constructor nil)
 352                (:constructor epg-make-sig-notation
 353                 (name value &optional human-readable critical))
 354                (:copier nil)
 355                (:predicate nil))
 356   name value human-readable critical)
 357
 358 (cl-defstruct (epg-import-status
 359                (:constructor nil)
 360                (:constructor epg-make-import-status
 361                 (fingerprint
 362                  &optional reason new user-id signature sub-key secret))
 363                (:copier nil)
 364                (:predicate nil))
 365   fingerprint reason new user-id signature sub-key secret)
 366
 367 (cl-defstruct (epg-import-result
 368                (:constructor nil)
 369                (:constructor epg-make-import-result
 370                 (considered no-user-id imported imported-rsa
 371                             unchanged new-user-ids new-sub-keys
 372                             new-signatures new-revocations
 373                             secret-read secret-imported
 374                             secret-unchanged not-imported
 375                             imports))
 376                (:copier nil)
 377                (:predicate nil))
 378   considered no-user-id imported imported-rsa
 379   unchanged new-user-ids new-sub-keys
 380   new-signatures new-revocations
 381   secret-read secret-imported
 382   secret-unchanged not-imported
 383   imports)
 384
 385 (defun epg-context-result-for (context name)
 386   "Return the result of CONTEXT associated with NAME."
 387   (cdr (assq name (epg-context-result context))))
 388
 389 (defun epg-context-set-result-for (context name value)
 390   "Set the result of CONTEXT associated with NAME to VALUE."
 391   (let* ((result (epg-context-result context))
 392          (entry (assq name result)))
 393     (if entry
 394         (setcdr entry value)
 395       (setf (epg-context-result context) (cons (cons name value) result)))))
 396
 397 (defun epg-signature-to-string (signature)
 398   "Convert SIGNATURE to a human readable string."
 399   (let* ((user-id (cdr (assoc (epg-signature-key-id signature)
 400                               epg-user-id-alist)))
 401          (pubkey-algorithm (epg-signature-pubkey-algorithm signature))
 402          (key-id (epg-signature-key-id signature)))
 403     (concat
 404      (cond ((eq (epg-signature-status signature) 'good)
 405             "Good signature from ")
 406            ((eq (epg-signature-status signature) 'bad)
 407             "Bad signature from ")
 408            ((eq (epg-signature-status signature) 'expired)
 409             "Expired signature from ")
 410            ((eq (epg-signature-status signature) 'expired-key)
 411             "Signature made by expired key ")
 412            ((eq (epg-signature-status signature) 'revoked-key)
 413             "Signature made by revoked key ")
 414            ((eq (epg-signature-status signature) 'no-pubkey)
 415             "No public key for "))
 416      key-id
 417      (if user-id
 418          (concat " "
 419                  (if (stringp user-id)
 420                      user-id
 421                    (epg-decode-dn user-id)))
 422        "")
 423      (if (epg-signature-validity signature)
 424          (format " (trust %s)"  (epg-signature-validity signature))
 425        "")
 426      (if (epg-signature-creation-time signature)
 427          (format-time-string " created at %Y-%m-%dT%T%z"
 428                              (epg-signature-creation-time signature))
 429        "")
 430      (if pubkey-algorithm
 431          (concat " using "
 432                  (or (cdr (assq pubkey-algorithm epg-pubkey-algorithm-alist))
 433                      (format "(unknown algorithm %d)" pubkey-algorithm)))
 434        ""))))
 435
 436 (defun epg-verify-result-to-string (verify-result)
 437   "Convert VERIFY-RESULT to a human readable string."
 438   (mapconcat #'epg-signature-to-string verify-result "\n"))
 439
 440 (defun epg-new-signature-to-string (new-signature)
 441   "Convert NEW-SIGNATURE to a human readable string."
 442   (concat
 443    (cond ((eq (epg-new-signature-type new-signature) 'detached)
 444           "Detached signature ")
 445          ((eq (epg-new-signature-type new-signature) 'clear)
 446           "Cleartext signature ")
 447          (t
 448           "Signature "))
 449    (cdr (assq (epg-new-signature-pubkey-algorithm new-signature)
 450               epg-pubkey-algorithm-alist))
 451    "/"
 452    (cdr (assq (epg-new-signature-digest-algorithm new-signature)
 453               epg-digest-algorithm-alist))
 454    " "
 455    (format "%02X " (epg-new-signature-class new-signature))
 456    (epg-new-signature-fingerprint new-signature)))
 457
 458 (defun epg-import-result-to-string (import-result)
 459   "Convert IMPORT-RESULT to a human readable string."
 460   (concat (format "Total number processed: %d\n"
 461                   (epg-import-result-considered import-result))
 462           (if (> (epg-import-result-not-imported import-result) 0)
 463               (format "      skipped new keys: %d\n"
 464                       (epg-import-result-not-imported import-result)))
 465           (if (> (epg-import-result-no-user-id import-result) 0)
 466               (format "          w/o user IDs: %d\n"
 467                       (epg-import-result-no-user-id import-result)))
 468           (if (> (epg-import-result-imported import-result) 0)
 469               (concat (format "              imported: %d"
 470                               (epg-import-result-imported import-result))
 471                       (if (> (epg-import-result-imported-rsa import-result) 0)
 472                           (format "  (RSA: %d)"
 473                                   (epg-import-result-imported-rsa
 474                                    import-result)))
 475                       "\n"))
 476           (if (> (epg-import-result-unchanged import-result) 0)
 477               (format "             unchanged: %d\n"
 478                       (epg-import-result-unchanged import-result)))
 479           (if (> (epg-import-result-new-user-ids import-result) 0)
 480               (format "          new user IDs: %d\n"
 481                       (epg-import-result-new-user-ids import-result)))
 482           (if (> (epg-import-result-new-sub-keys import-result) 0)
 483               (format "           new subkeys: %d\n"
 484                       (epg-import-result-new-sub-keys import-result)))
 485           (if (> (epg-import-result-new-signatures import-result) 0)
 486               (format "        new signatures: %d\n"
 487                       (epg-import-result-new-signatures import-result)))
 488           (if (> (epg-import-result-new-revocations import-result) 0)
 489               (format "   new key revocations: %d\n"
 490                       (epg-import-result-new-revocations import-result)))
 491           (if (> (epg-import-result-secret-read import-result) 0)
 492               (format "      secret keys read: %d\n"
 493                       (epg-import-result-secret-read import-result)))
 494           (if (> (epg-import-result-secret-imported import-result) 0)
 495               (format "  secret keys imported: %d\n"
 496                       (epg-import-result-secret-imported import-result)))
 497           (if (> (epg-import-result-secret-unchanged import-result) 0)
 498               (format " secret keys unchanged: %d\n"
 499                       (epg-import-result-secret-unchanged import-result)))))
 500
 501 (defun epg-error-to-string (error)
 502   (cond
 503    ((eq (car error) 'exit)
 504     "Exit")
 505    ((eq (car error) 'quit)
 506     "Canceled")
 507    ((eq (car error) 'no-data)
 508     (let ((entry (assq (cdr error) epg-no-data-reason-alist)))
 509       (if entry
 510           (format "No data (%s)" (downcase (cdr entry)))
 511         "No data")))
 512    ((eq (car error) 'unexpected)
 513     (let ((entry (assq (cdr error) epg-unexpected-reason-alist)))
 514       (if entry
 515           (format "Unexpected (%s)" (downcase (cdr entry)))
 516         "Unexpected")))
 517    ((eq (car error) 'bad-armor)
 518     "Bad armor")
 519    ((memq (car error) '(invalid-recipient invalid-signer))
 520     (concat
 521      (if (eq (car error) 'invalid-recipient)
 522          "Unusable public key"
 523        "Unusable secret key")
 524      (let ((entry (assq 'requested (cdr error))))
 525        (if entry
 526            (format ": %s" (cdr entry))
 527          ": <unknown>"))
 528      (let ((entry (assq 'reason (cdr error))))
 529        (if (and entry
 530                 (> (cdr entry) 0)       ;no specific reason given
 531                 (setq entry (assq (cdr entry)
 532                                   epg-invalid-recipients-reason-alist)))
 533            (format " (%s)" (downcase (cdr entry)))
 534          ""))))
 535    ((eq (car error) 'no-pubkey)
 536     (format "No public key: %s" (cdr error)))
 537    ((eq (car error) 'no-seckey)
 538     (format "No secret key: %s" (cdr error)))
 539    ((eq (car error) 'no-recipients)
 540     "No recipients")
 541    ((eq (car error) 'no-signers)
 542     "No signers")
 543    ((eq (car error) 'delete-problem)
 544     (let ((entry (assq (cdr error) epg-delete-problem-reason-alist)))
 545       (if entry
 546           (format "Delete problem (%s)" (downcase (cdr entry)))
 547         "Delete problem")))
 548    ((eq (car error) 'key-not-created)
 549     "Key not created")))
 550
 551 (defun epg-errors-to-string (errors)
 552   (mapconcat #'epg-error-to-string errors "; "))
 553
 554 (declare-function pinentry-start "pinentry" (&optional quiet))
 555
 556 (defun epg--start (context args)
 557   "Start `epg-gpg-program' in a subprocess with given ARGS."
 558   (if (and (epg-context-process context)
 559            (eq (process-status (epg-context-process context)) 'run))
 560       (error "%s is already running in this context"
 561              (epg-context-program context)))
 562   (let* ((agent-info (getenv "GPG_AGENT_INFO"))
 563          (args (append (list "--no-tty"
 564                              "--status-fd" "1"
 565                              "--yes")
 566                        (if (and (not (eq (epg-context-protocol context) 'CMS))
 567                                 (string-match ":" (or agent-info "")))
 568                            '("--use-agent"))
 569                        (if (and (not (eq (epg-context-protocol context) 'CMS))
 570                                 (epg-context-progress-callback context))
 571                            '("--enable-progress-filter"))
 572                        (if (epg-context-home-directory context)
 573                            (list "--homedir"
 574                                  (epg-context-home-directory context)))
 575                        (unless (eq (epg-context-protocol context) 'CMS)
 576                          '("--command-fd" "0"))
 577                        (if (epg-context-armor context) '("--armor"))
 578                        (if (epg-context-textmode context) '("--textmode"))
 579                        (if (epg-context-output-file context)
 580                            (list "--output" (epg-context-output-file context)))
 581                        (if (epg-context-pinentry-mode context)
 582                            (list "--pinentry-mode"
 583                                  (symbol-name (epg-context-pinentry-mode
 584                                                context))))
 585                        args))
 586          (process-environment process-environment)
 587          (buffer (generate-new-buffer " *epg*"))
 588          error-process
 589          process
 590          terminal-name
 591          agent-file
 592          (agent-mtime '(0 0 0 0)))
 593     ;; Set GPG_TTY and TERM for pinentry-curses.  Note that we can't
 594     ;; use `terminal-name' here to get the real pty name for the child
 595     ;; process, though /dev/fd/0" is not portable.
 596     (unless (memq system-type '(ms-dos windows-nt))
 597       (with-temp-buffer
 598         (condition-case nil
 599             (when (= (call-process "tty" "/dev/fd/0" t) 0)
 600               (delete-char -1)
 601               (setq terminal-name (buffer-string)))
 602           (file-error))))
 603     (when terminal-name
 604       (setq process-environment
 605             (cons (concat "GPG_TTY=" terminal-name)
 606                   (cons "TERM=xterm" process-environment))))
 607     ;; Start the Emacs Pinentry server if allow-emacs-pinentry is set
 608     ;; in ~/.gnupg/gpg-agent.conf.
 609     (when (and (fboundp 'pinentry-start)
 610                (executable-find epg-gpgconf-program)
 611                (with-temp-buffer
 612                  (when (= (call-process epg-gpgconf-program nil t nil
 613                                         "--list-options" "gpg-agent")
 614                           0)
 615                    (goto-char (point-min))
 616                    (re-search-forward
 617                     "^allow-emacs-pinentry:\\(?:.*:\\)\\{8\\}1"
 618                     nil t))))
 619       (pinentry-start 'quiet))
 620     (setq process-environment
 621           (cons (format "INSIDE_EMACS=%s,epg" emacs-version)
 622                 process-environment))
 623     ;; Record modified time of gpg-agent socket to restore the Emacs
 624     ;; frame on text terminal in `epg-wait-for-completion'.
 625     ;; See
 626     ;; <http://lists.gnu.org/archive/html/emacs-devel/2007-02/msg00755.html>
 627     ;; for more details.
 628     (when (and agent-info (string-match "\\(.*\\):[0-9]+:[0-9]+" agent-info))
 629       (setq agent-file (match-string 1 agent-info)
 630             agent-mtime (or (nth 5 (file-attributes agent-file)) '(0 0 0 0))))
 631     (if epg-debug
 632         (save-excursion
 633           (unless epg-debug-buffer
 634             (setq epg-debug-buffer (generate-new-buffer " *epg-debug*")))
 635           (set-buffer epg-debug-buffer)
 636           (goto-char (point-max))
 637           (insert (if agent-info
 638                       (format "GPG_AGENT_INFO=%s\n" agent-info)
 639                     "GPG_AGENT_INFO is not set\n")
 640                   (format "%s %s\n"
 641                           (epg-context-program context)
 642                           (mapconcat #'identity args " ")))))
 643     (with-current-buffer buffer
 644       (if (fboundp 'set-buffer-multibyte)
 645           (set-buffer-multibyte nil))
 646       (make-local-variable 'epg-last-status)
 647       (setq epg-last-status nil)
 648       (make-local-variable 'epg-read-point)
 649       (setq epg-read-point (point-min))
 650       (make-local-variable 'epg-process-filter-running)
 651       (setq epg-process-filter-running nil)
 652       (make-local-variable 'epg-pending-status-list)
 653       (setq epg-pending-status-list nil)
 654       (make-local-variable 'epg-key-id)
 655       (setq epg-key-id nil)
 656       (make-local-variable 'epg-context)
 657       (setq epg-context context)
 658       (make-local-variable 'epg-agent-file)
 659       (setq epg-agent-file agent-file)
 660       (make-local-variable 'epg-agent-mtime)
 661       (setq epg-agent-mtime agent-mtime))
 662     (setq error-process
 663           (make-pipe-process :name "epg-error"
 664                              :buffer (generate-new-buffer " *epg-error*")
 665                              ;; Suppress "XXX finished" line.
 666                              :sentinel #'ignore
 667                              :noquery t))
 668     (setf (epg-context-error-buffer context) (process-buffer error-process))
 669     (with-file-modes 448
 670       (setq process (make-process :name "epg"
 671                                   :buffer buffer
 672                                   :command (cons (epg-context-program context)
 673                                                  args)
 674                                   :connection-type 'pipe
 675                                   :coding '(binary . binary)
 676                                   :filter #'epg--process-filter
 677                                   :stderr error-process
 678                                   :noquery t)))
 679     (setf (epg-context-process context) process)))
 680
 681 (defun epg--process-filter (process input)
 682   (if epg-debug
 683       (with-current-buffer
 684           (or epg-debug-buffer
 685               (setq epg-debug-buffer (generate-new-buffer " *epg-debug*")))
 686         (goto-char (point-max))
 687         (insert input)))
 688   (if (buffer-live-p (process-buffer process))
 689       (with-current-buffer (process-buffer process)
 690         (save-excursion
 691           (goto-char (point-max))
 692           (insert input)
 693           (unless epg-process-filter-running
 694             (let ((epg-process-filter-running t))
 695               (goto-char epg-read-point)
 696               (beginning-of-line)
 697               (while (looking-at ".*\n") ;the input line finished
 698                 (if (looking-at "\\[GNUPG:] \\([A-Z_]+\\) ?\\(.*\\)")
 699                     (let ((status (match-string 1))
 700                           (string (match-string 2))
 701                           symbol)
 702                       (if (member status epg-pending-status-list)
 703                           (setq epg-pending-status-list nil))
 704                       ;; When editing a key, delegate all interaction
 705                       ;; to edit-callback.
 706                       (if (eq (epg-context-operation epg-context) 'edit-key)
 707                           (funcall (car (epg-context-edit-callback
 708                                          epg-context))
 709                                    epg-context
 710                                    status
 711                                    string
 712                                    (cdr (epg-context-edit-callback
 713                                          epg-context)))
 714                         ;; Otherwise call epg--status-STATUS function.
 715                         (setq symbol (intern-soft (concat "epg--status-"
 716                                                           status)))
 717                         (if (and symbol
 718                                  (fboundp symbol))
 719                             (funcall symbol epg-context string)))
 720                       (setq epg-last-status (cons status string))))
 721                 (forward-line)
 722                 (setq epg-read-point (point)))))))))
 723
 724 (defun epg-read-output (context)
 725   "Read the output file CONTEXT and return the content as a string."
 726   (with-temp-buffer
 727     (if (fboundp 'set-buffer-multibyte)
 728         (set-buffer-multibyte nil))
 729     (if (file-exists-p (epg-context-output-file context))
 730         (let ((coding-system-for-read 'binary))
 731           (insert-file-contents (epg-context-output-file context))
 732           (buffer-string)))))
 733
 734 (defun epg-wait-for-status (context status-list)
 735   "Wait until one of elements in STATUS-LIST arrives."
 736   (with-current-buffer (process-buffer (epg-context-process context))
 737     (setq epg-pending-status-list status-list)
 738     (while (and (eq (process-status (epg-context-process context)) 'run)
 739                 epg-pending-status-list)
 740       (accept-process-output (epg-context-process context) 1))
 741     (if epg-pending-status-list
 742         (epg-context-set-result-for
 743          context 'error
 744          (cons '(exit)
 745                (epg-context-result-for context 'error))))))
 746
 747 (defun epg-wait-for-completion (context)
 748   "Wait until the `epg-gpg-program' process completes."
 749   (while (eq (process-status (epg-context-process context)) 'run)
 750     (accept-process-output (epg-context-process context) 1))
 751   ;; This line is needed to run the process-filter right now.
 752   (sleep-for 0.1)
 753   ;; Restore Emacs frame on text terminal, when pinentry-curses has terminated.
 754   (if (with-current-buffer (process-buffer (epg-context-process context))
 755         (and epg-agent-file
 756              (> (float-time (or (nth 5 (file-attributes epg-agent-file))
 757                                 '(0 0 0 0)))
 758                 (float-time epg-agent-mtime))))
 759       (redraw-frame))
 760   (epg-context-set-result-for
 761    context 'error
 762    (nreverse (epg-context-result-for context 'error)))
 763   (setf (epg-context-error-output context)
 764         (with-current-buffer (epg-context-error-buffer context)
 765           (buffer-string))))
 766
 767 (defun epg-reset (context)
 768   "Reset the CONTEXT."
 769   (if (and (epg-context-process context)
 770            (buffer-live-p (process-buffer (epg-context-process context))))
 771       (kill-buffer (process-buffer (epg-context-process context))))
 772   (if (buffer-live-p (epg-context-error-buffer context))
 773       (kill-buffer (epg-context-error-buffer context)))
 774   (setf (epg-context-process context) nil)
 775   (setf (epg-context-edit-callback context) nil))
 776
 777 (defun epg-delete-output-file (context)
 778   "Delete the output file of CONTEXT."
 779   (if (and (epg-context-output-file context)
 780            (file-exists-p (epg-context-output-file context)))
 781       (delete-file (epg-context-output-file context))))
 782
 783 (eval-and-compile
 784   (if (fboundp 'decode-coding-string)
 785       (defalias 'epg--decode-coding-string 'decode-coding-string)
 786     (defalias 'epg--decode-coding-string 'identity)))
 787
 788 (defun epg--status-USERID_HINT (_context string)
 789   (if (string-match "\\`\\([^ ]+\\) \\(.*\\)" string)
 790       (let* ((key-id (match-string 1 string))
 791              (user-id (match-string 2 string))
 792              (entry (assoc key-id epg-user-id-alist)))
 793         (condition-case nil
 794             (setq user-id (epg--decode-coding-string
 795                            (epg--decode-percent-escape user-id)
 796                            'utf-8))
 797           (error))
 798         (if entry
 799             (setcdr entry user-id)
 800           (setq epg-user-id-alist (cons (cons key-id user-id)
 801                                         epg-user-id-alist))))))
 802
 803 (defun epg--status-NEED_PASSPHRASE (_context string)
 804   (if (string-match "\\`\\([^ ]+\\)" string)
 805       (setq epg-key-id (match-string 1 string))))
 806
 807 (defun epg--status-NEED_PASSPHRASE_SYM (_context _string)
 808   (setq epg-key-id 'SYM))
 809
 810 (defun epg--status-NEED_PASSPHRASE_PIN (_context _string)
 811   (setq epg-key-id 'PIN))
 812
 813 (eval-and-compile
 814   (if (fboundp 'clear-string)
 815       (defalias 'epg--clear-string 'clear-string)
 816     (defun epg--clear-string (string)
 817       (fillarray string 0))))
 818
 819 (eval-and-compile
 820   (if (fboundp 'encode-coding-string)
 821       (defalias 'epg--encode-coding-string 'encode-coding-string)
 822     (defalias 'epg--encode-coding-string 'identity)))
 823
 824 (defun epg--status-GET_HIDDEN (context string)
 825   (when (and epg-key-id
 826              (string-match "\\`passphrase\\." string))
 827     (unless (epg-context-passphrase-callback context)
 828       (error "passphrase-callback not set"))
 829     (let (inhibit-quit
 830           passphrase
 831           passphrase-with-new-line
 832           encoded-passphrase-with-new-line)
 833       (unwind-protect
 834           (condition-case nil
 835               (progn
 836                 (setq passphrase
 837                       (funcall
 838                        (car (epg-context-passphrase-callback context))
 839                        context
 840                        epg-key-id
 841                        (cdr (epg-context-passphrase-callback context))))
 842                 (when passphrase
 843                   (setq passphrase-with-new-line (concat passphrase "\n"))
 844                   (epg--clear-string passphrase)
 845                   (setq passphrase nil)
 846                   (if epg-passphrase-coding-system
 847                       (progn
 848                         (setq encoded-passphrase-with-new-line
 849                               (epg--encode-coding-string
 850                                passphrase-with-new-line
 851                                (coding-system-change-eol-conversion
 852                                 epg-passphrase-coding-system 'unix)))
 853                         (epg--clear-string passphrase-with-new-line)
 854                         (setq passphrase-with-new-line nil))
 855                     (setq encoded-passphrase-with-new-line
 856                           passphrase-with-new-line
 857                           passphrase-with-new-line nil))
 858                   (process-send-string (epg-context-process context)
 859                                        encoded-passphrase-with-new-line)))
 860             (quit
 861              (epg-context-set-result-for
 862               context 'error
 863               (cons '(quit)
 864                     (epg-context-result-for context 'error)))
 865              (delete-process (epg-context-process context))))
 866         (if passphrase
 867             (epg--clear-string passphrase))
 868         (if passphrase-with-new-line
 869             (epg--clear-string passphrase-with-new-line))
 870         (if encoded-passphrase-with-new-line
 871             (epg--clear-string encoded-passphrase-with-new-line))))))
 872
 873 (defun epg--prompt-GET_BOOL (_context string)
 874   (let ((entry (assoc string epg-prompt-alist)))
 875     (y-or-n-p (if entry (cdr entry) (concat string "? ")))))
 876
 877 (defun epg--prompt-GET_BOOL-untrusted_key.override (_context _string)
 878   (y-or-n-p (if (and (equal (car epg-last-status) "USERID_HINT")
 879                      (string-match "\\`\\([^ ]+\\) \\(.*\\)"
 880                                    (cdr epg-last-status)))
 881                 (let* ((key-id (match-string 1 (cdr epg-last-status)))
 882                        (user-id (match-string 2 (cdr epg-last-status)))
 883                        (entry (assoc key-id epg-user-id-alist)))
 884                   (if entry
 885                       (setq user-id (cdr entry)))
 886                   (format "Untrusted key %s %s.  Use anyway? " key-id user-id))
 887               "Use untrusted key anyway? ")))
 888
 889 (defun epg--status-GET_BOOL (context string)
 890   (let (inhibit-quit)
 891     (condition-case nil
 892         (if (funcall (or (intern-soft (concat "epg--prompt-GET_BOOL-" string))
 893                          #'epg--prompt-GET_BOOL)
 894                      context string)
 895             (process-send-string (epg-context-process context) "y\n")
 896           (process-send-string (epg-context-process context) "n\n"))
 897       (quit
 898        (epg-context-set-result-for
 899         context 'error
 900         (cons '(quit)
 901               (epg-context-result-for context 'error)))
 902        (delete-process (epg-context-process context))))))
 903
 904 (defun epg--status-GET_LINE (context string)
 905   (let ((entry (assoc string epg-prompt-alist))
 906         inhibit-quit)
 907     (condition-case nil
 908         (process-send-string (epg-context-process context)
 909                              (concat (read-string
 910                                       (if entry
 911                                           (cdr entry)
 912                                         (concat string ": ")))
 913                                      "\n"))
 914       (quit
 915        (epg-context-set-result-for
 916         context 'error
 917         (cons '(quit)
 918               (epg-context-result-for context 'error)))
 919        (delete-process (epg-context-process context))))))
 920
 921 (defun epg--status-*SIG (context status string)
 922   (if (string-match "\\`\\([^ ]+\\) \\(.*\\)" string)
 923       (let* ((key-id (match-string 1 string))
 924              (user-id (match-string 2 string))
 925              (entry (assoc key-id epg-user-id-alist)))
 926         (epg-context-set-result-for
 927          context
 928          'verify
 929          (cons (epg-make-signature status key-id)
 930                (epg-context-result-for context 'verify)))
 931         (condition-case nil
 932             (if (eq (epg-context-protocol context) 'CMS)
 933                 (setq user-id (epg-dn-from-string user-id))
 934               (setq user-id (epg--decode-coding-string
 935                              (epg--decode-percent-escape user-id)
 936                              'utf-8)))
 937           (error))
 938         (if entry
 939             (setcdr entry user-id)
 940           (setq epg-user-id-alist
 941                 (cons (cons key-id user-id) epg-user-id-alist))))
 942     (epg-context-set-result-for
 943      context
 944      'verify
 945      (cons (epg-make-signature status)
 946            (epg-context-result-for context 'verify)))))
 947
 948 (defun epg--status-GOODSIG (context string)
 949   (epg--status-*SIG context 'good string))
 950
 951 (defun epg--status-EXPSIG (context string)
 952   (epg--status-*SIG context 'expired string))
 953
 954 (defun epg--status-EXPKEYSIG (context string)
 955   (epg--status-*SIG context 'expired-key string))
 956
 957 (defun epg--status-REVKEYSIG (context string)
 958   (epg--status-*SIG context 'revoked-key string))
 959
 960 (defun epg--status-BADSIG (context string)
 961   (epg--status-*SIG context 'bad string))
 962
 963 (defun epg--status-NO_PUBKEY (context string)
 964   (if (eq (epg-context-operation context) 'verify)
 965       (let ((signature (car (epg-context-result-for context 'verify))))
 966         (if (and signature
 967                  (eq (epg-signature-status signature) 'error)
 968                  (equal (epg-signature-key-id signature) string))
 969             (setf (epg-signature-status signature) 'no-pubkey)))
 970     (epg-context-set-result-for
 971      context 'error
 972      (cons (cons 'no-pubkey string)
 973            (epg-context-result-for context 'error)))))
 974
 975 (defun epg--status-NO_SECKEY (context string)
 976   (epg-context-set-result-for
 977    context 'error
 978    (cons (cons 'no-seckey string)
 979          (epg-context-result-for context 'error))))
 980
 981 (defun epg--time-from-seconds (seconds)
 982   (let ((number-seconds (string-to-number (concat seconds ".0"))))
 983     (cons (floor (/ number-seconds 65536))
 984           (floor (mod number-seconds 65536)))))
 985
 986 (defun epg--status-ERRSIG (context string)
 987   (if (string-match "\\`\\([^ ]+\\) \\([0-9]+\\) \\([0-9]+\\) \
 988 \\([0-9A-Fa-f][0-9A-Fa-f]\\) \\([^ ]+\\) \\([0-9]+\\)"
 989                     string)
 990       (let ((signature (epg-make-signature 'error)))
 991         (epg-context-set-result-for
 992          context
 993          'verify
 994          (cons signature
 995                (epg-context-result-for context 'verify)))
 996         (setf (epg-signature-key-id signature)
 997               (match-string 1 string))
 998         (setf (epg-signature-pubkey-algorithm signature)
 999               (string-to-number (match-string 2 string)))
1000         (setf (epg-signature-digest-algorithm signature)
1001               (string-to-number (match-string 3 string)))
1002         (setf (epg-signature-class signature)
1003               (string-to-number (match-string 4 string) 16))
1004         (setf (epg-signature-creation-time signature)
1005               (epg--time-from-seconds (match-string 5 string))))))
1006
1007 (defun epg--status-VALIDSIG (context string)
1008   (let ((signature (car (epg-context-result-for context 'verify))))
1009     (when (and signature
1010                (eq (epg-signature-status signature) 'good)
1011                (string-match "\\`\\([^ ]+\\) [^ ]+ \\([^ ]+\\) \\([^ ]+\\) \
1012 \\([0-9]+\\) [^ ]+ \\([0-9]+\\) \\([0-9]+\\) \\([0-9A-Fa-f][0-9A-Fa-f]\\) \
1013 \\(.*\\)"
1014                            string))
1015       (setf (epg-signature-fingerprint signature)
1016             (match-string 1 string))
1017       (setf (epg-signature-creation-time signature)
1018             (epg--time-from-seconds (match-string 2 string)))
1019       (unless (equal (match-string 3 string) "0")
1020         (setf (epg-signature-expiration-time signature)
1021               (epg--time-from-seconds (match-string 3 string))))
1022       (setf (epg-signature-version signature)
1023             (string-to-number (match-string 4 string)))
1024       (setf (epg-signature-pubkey-algorithm signature)
1025             (string-to-number (match-string 5 string)))
1026       (setf (epg-signature-digest-algorithm signature)
1027             (string-to-number (match-string 6 string)))
1028       (setf (epg-signature-class signature)
1029             (string-to-number (match-string 7 string) 16)))))
1030
1031 (defun epg--status-TRUST_UNDEFINED (context _string)
1032   (let ((signature (car (epg-context-result-for context 'verify))))
1033     (if (and signature
1034              (eq (epg-signature-status signature) 'good))
1035         (setf (epg-signature-validity signature) 'undefined))))
1036
1037 (defun epg--status-TRUST_NEVER (context _string)
1038   (let ((signature (car (epg-context-result-for context 'verify))))
1039     (if (and signature
1040              (eq (epg-signature-status signature) 'good))
1041         (setf (epg-signature-validity signature) 'never))))
1042
1043 (defun epg--status-TRUST_MARGINAL (context _string)
1044   (let ((signature (car (epg-context-result-for context 'verify))))
1045     (if (and signature
1046              (eq (epg-signature-status signature) 'marginal))
1047         (setf (epg-signature-validity signature) 'marginal))))
1048
1049 (defun epg--status-TRUST_FULLY (context _string)
1050   (let ((signature (car (epg-context-result-for context 'verify))))
1051     (if (and signature
1052              (eq (epg-signature-status signature) 'good))
1053         (setf (epg-signature-validity signature) 'full))))
1054
1055 (defun epg--status-TRUST_ULTIMATE (context _string)
1056   (let ((signature (car (epg-context-result-for context 'verify))))
1057     (if (and signature
1058              (eq (epg-signature-status signature) 'good))
1059         (setf (epg-signature-validity signature) 'ultimate))))
1060
1061 (defun epg--status-NOTATION_NAME (context string)
1062   (let ((signature (car (epg-context-result-for context 'verify))))
1063     (if signature
1064         (push (epg-make-sig-notation string nil t nil)
1065               (epg-signature-notations signature)))))
1066
1067 (defun epg--status-NOTATION_DATA (context string)
1068   (let ((signature (car (epg-context-result-for context 'verify)))
1069         notation)
1070     (if (and signature
1071              (setq notation (car (epg-signature-notations signature))))
1072         (setf (epg-sig-notation-value notation) string))))
1073
1074 (defun epg--status-POLICY_URL (context string)
1075   (let ((signature (car (epg-context-result-for context 'verify))))
1076     (if signature
1077         (push (epg-make-sig-notation nil string t nil)
1078               (epg-signature-notations signature)))))
1079
1080 (defun epg--status-PROGRESS (context string)
1081   (if (and (epg-context-progress-callback context)
1082            (string-match "\\`\\([^ ]+\\) \\([^ ]\\) \\([0-9]+\\) \\([0-9]+\\)"
1083                          string))
1084       (funcall (car (epg-context-progress-callback context))
1085                context
1086                (match-string 1 string)
1087                (match-string 2 string)
1088                (string-to-number (match-string 3 string))
1089                (string-to-number (match-string 4 string))
1090                (cdr (epg-context-progress-callback context)))))
1091
1092 (defun epg--status-ENC_TO (context string)
1093   (if (string-match "\\`\\([0-9A-Za-z]+\\) \\([0-9]+\\) \\([0-9]+\\)" string)
1094       (epg-context-set-result-for
1095        context 'encrypted-to
1096        (cons (list (match-string 1 string)
1097                    (string-to-number (match-string 2 string))
1098                    (string-to-number (match-string 3 string)))
1099              (epg-context-result-for context 'encrypted-to)))))
1100
1101 (defun epg--status-DECRYPTION_FAILED (context _string)
1102   (epg-context-set-result-for context 'decryption-failed t))
1103
1104 (defun epg--status-DECRYPTION_OKAY (context _string)
1105   (epg-context-set-result-for context 'decryption-okay t))
1106
1107 (defun epg--status-NODATA (context string)
1108   (epg-context-set-result-for
1109    context 'error
1110    (cons (cons 'no-data (string-to-number string))
1111          (epg-context-result-for context 'error))))
1112
1113 (defun epg--status-UNEXPECTED (context string)
1114   (epg-context-set-result-for
1115    context 'error
1116    (cons (cons 'unexpected (string-to-number string))
1117          (epg-context-result-for context 'error))))
1118
1119 (defun epg--status-KEYEXPIRED (context string)
1120   (epg-context-set-result-for
1121    context 'key
1122    (cons (list 'key-expired (cons 'expiration-time
1123                                   (epg--time-from-seconds string)))
1124          (epg-context-result-for context 'key))))
1125
1126 (defun epg--status-KEYREVOKED (context _string)
1127   (epg-context-set-result-for
1128    context 'key
1129    (cons '(key-revoked)
1130          (epg-context-result-for context 'key))))
1131
1132 (defun epg--status-BADARMOR (context _string)
1133   (epg-context-set-result-for
1134    context 'error
1135    (cons '(bad-armor)
1136          (epg-context-result-for context 'error))))
1137
1138 (defun epg--status-INV_RECP (context string)
1139   (if (string-match "\\`\\([0-9]+\\) \\(.*\\)" string)
1140       (epg-context-set-result-for
1141        context 'error
1142        (cons (list 'invalid-recipient
1143                    (cons 'reason
1144                          (string-to-number (match-string 1 string)))
1145                    (cons 'requested
1146                          (match-string 2 string)))
1147              (epg-context-result-for context 'error)))))
1148
1149 (defun epg--status-INV_SGNR (context string)
1150   (if (string-match "\\`\\([0-9]+\\) \\(.*\\)" string)
1151       (epg-context-set-result-for
1152        context 'error
1153        (cons (list 'invalid-signer
1154                    (cons 'reason
1155                          (string-to-number (match-string 1 string)))
1156                    (cons 'requested
1157                          (match-string 2 string)))
1158              (epg-context-result-for context 'error)))))
1159
1160 (defun epg--status-NO_RECP (context _string)
1161   (epg-context-set-result-for
1162    context 'error
1163    (cons '(no-recipients)
1164          (epg-context-result-for context 'error))))
1165
1166 (defun epg--status-NO_SGNR (context _string)
1167   (epg-context-set-result-for
1168    context 'error
1169    (cons '(no-signers)
1170          (epg-context-result-for context 'error))))
1171
1172 (defun epg--status-DELETE_PROBLEM (context string)
1173   (if (string-match "\\`\\([0-9]+\\)" string)
1174       (epg-context-set-result-for
1175        context 'error
1176        (cons (cons 'delete-problem
1177                    (string-to-number (match-string 1 string)))
1178              (epg-context-result-for context 'error)))))
1179
1180 (defun epg--status-SIG_CREATED (context string)
1181   (if (string-match "\\`\\([DCS]\\) \\([0-9]+\\) \\([0-9]+\\) \
1182 \\([0-9A-Fa-F][0-9A-Fa-F]\\) \\(.*\\) " string)
1183       (epg-context-set-result-for
1184        context 'sign
1185        (cons (epg-make-new-signature
1186               (cdr (assq (aref (match-string 1 string) 0)
1187                          epg-new-signature-type-alist))
1188               (string-to-number (match-string 2 string))
1189               (string-to-number (match-string 3 string))
1190               (string-to-number (match-string 4 string) 16)
1191               (epg--time-from-seconds (match-string 5 string))
1192               (substring string (match-end 0)))
1193              (epg-context-result-for context 'sign)))))
1194
1195 (defun epg--status-KEY_CREATED (context string)
1196   (if (string-match "\\`\\([BPS]\\) \\([^ ]+\\)" string)
1197       (epg-context-set-result-for
1198        context 'generate-key
1199        (cons (list (cons 'type (string-to-char (match-string 1 string)))
1200                    (cons 'fingerprint (match-string 2 string)))
1201              (epg-context-result-for context 'generate-key)))))
1202
1203 (defun epg--status-KEY_NOT_CREATED (context _string)
1204   (epg-context-set-result-for
1205    context 'error
1206    (cons '(key-not-created)
1207          (epg-context-result-for context 'error))))
1208
1209 (defun epg--status-IMPORTED (_context string)
1210   (if (string-match "\\`\\([^ ]+\\) \\(.*\\)" string)
1211       (let* ((key-id (match-string 1 string))
1212              (user-id (match-string 2 string))
1213              (entry (assoc key-id epg-user-id-alist)))
1214         (condition-case nil
1215             (setq user-id (epg--decode-coding-string
1216                            (epg--decode-percent-escape user-id)
1217                            'utf-8))
1218           (error))
1219         (if entry
1220             (setcdr entry user-id)
1221           (setq epg-user-id-alist (cons (cons key-id user-id)
1222                                         epg-user-id-alist))))))
1223
1224 (defun epg--status-IMPORT_OK (context string)
1225   (if (string-match "\\`\\([0-9]+\\)\\( \\(.+\\)\\)?" string)
1226       (let ((reason (string-to-number (match-string 1 string))))
1227         (epg-context-set-result-for
1228          context 'import-status
1229          (cons (epg-make-import-status (if (match-beginning 2)
1230                                            (match-string 3 string))
1231                                        nil
1232                                        (/= (logand reason 1) 0)
1233                                        (/= (logand reason 2) 0)
1234                                        (/= (logand reason 4) 0)
1235                                        (/= (logand reason 8) 0)
1236                                        (/= (logand reason 16) 0))
1237                (epg-context-result-for context 'import-status))))))
1238
1239 (defun epg--status-IMPORT_PROBLEM (context string)
1240   (if (string-match "\\`\\([0-9]+\\)\\( \\(.+\\)\\)?" string)
1241       (epg-context-set-result-for
1242        context 'import-status
1243        (cons (epg-make-import-status
1244               (if (match-beginning 2)
1245                   (match-string 3 string))
1246               (string-to-number (match-string 1 string)))
1247              (epg-context-result-for context 'import-status)))))
1248
1249 (defun epg--status-IMPORT_RES (context string)
1250   (when (string-match "\\`\\([0-9]+\\) \\([0-9]+\\) \\([0-9]+\\) \\([0-9]+\\) \
1251 \\([0-9]+\\) \\([0-9]+\\) \\([0-9]+\\) \\([0-9]+\\) \\([0-9]+\\) \\([0-9]+\\) \
1252 \\([0-9]+\\) \\([0-9]+\\) \\([0-9]+\\)" string)
1253     (epg-context-set-result-for
1254      context 'import
1255      (epg-make-import-result (string-to-number (match-string 1 string))
1256                              (string-to-number (match-string 2 string))
1257                              (string-to-number (match-string 3 string))
1258                              (string-to-number (match-string 4 string))
1259                              (string-to-number (match-string 5 string))
1260                              (string-to-number (match-string 6 string))
1261                              (string-to-number (match-string 7 string))
1262                              (string-to-number (match-string 8 string))
1263                              (string-to-number (match-string 9 string))
1264                              (string-to-number (match-string 10 string))
1265                              (string-to-number (match-string 11 string))
1266                              (string-to-number (match-string 12 string))
1267                              (string-to-number (match-string 13 string))
1268                              (epg-context-result-for context 'import-status)))
1269     (epg-context-set-result-for context 'import-status nil)))
1270
1271 (defun epg-passphrase-callback-function (context key-id _handback)
1272   (declare (obsolete epa-passphrase-callback-function "23.1"))
1273   (if (eq key-id 'SYM)
1274       (read-passwd "Passphrase for symmetric encryption: "
1275                    (eq (epg-context-operation context) 'encrypt))
1276     (read-passwd
1277      (if (eq key-id 'PIN)
1278         "Passphrase for PIN: "
1279        (let ((entry (assoc key-id epg-user-id-alist)))
1280          (if entry
1281              (format "Passphrase for %s %s: " key-id (cdr entry))
1282            (format "Passphrase for %s: " key-id)))))))
1283
1284 (defun epg--list-keys-1 (context name mode)
1285   (let ((args (append (if (epg-context-home-directory context)
1286                           (list "--homedir"
1287                                 (epg-context-home-directory context)))
1288                       '("--with-colons" "--no-greeting" "--batch"
1289                         "--with-fingerprint" "--with-fingerprint")
1290                       (unless (eq (epg-context-protocol context) 'CMS)
1291                         '("--fixed-list-mode"))))
1292         (list-keys-option (if (memq mode '(t secret))
1293                               "--list-secret-keys"
1294                             (if (memq mode '(nil public))
1295                                 "--list-keys"
1296                               "--list-sigs")))
1297         (coding-system-for-read 'binary)
1298         keys string field index)
1299     (if name
1300         (progn
1301           (unless (listp name)
1302             (setq name (list name)))
1303           (while name
1304             (setq args (append args (list list-keys-option (car name)))
1305                   name (cdr name))))
1306       (setq args (append args (list list-keys-option))))
1307     (with-temp-buffer
1308       (apply #'call-process
1309              (epg-context-program context)
1310              nil (list t nil) nil args)
1311       (goto-char (point-min))
1312       (while (re-search-forward "^[a-z][a-z][a-z]:.*" nil t)
1313         (setq keys (cons (make-vector 15 nil) keys)
1314               string (match-string 0)
1315               index 0
1316               field 0)
1317         (while (and (< field (length (car keys)))
1318                     (eq index
1319                         (string-match "\\([^:]+\\)?:" string index)))
1320           (setq index (match-end 0))
1321           (aset (car keys) field (match-string 1 string))
1322           (setq field (1+ field))))
1323       (nreverse keys))))
1324
1325 (defun epg--make-sub-key-1 (line)
1326   (epg-make-sub-key
1327    (if (aref line 1)
1328        (cdr (assq (string-to-char (aref line 1)) epg-key-validity-alist)))
1329    (delq nil
1330          (mapcar (lambda (char) (cdr (assq char epg-key-capability-alist)))
1331                  (aref line 11)))
1332    (member (aref line 0) '("sec" "ssb"))
1333    (string-to-number (aref line 3))
1334    (string-to-number (aref line 2))
1335    (aref line 4)
1336    (epg--time-from-seconds (aref line 5))
1337    (if (aref line 6)
1338        (epg--time-from-seconds (aref line 6)))))
1339
1340 (defun epg-list-keys (context &optional name mode)
1341   "Return a list of epg-key objects matched with NAME.
1342 If MODE is nil or `public', only public keyring should be searched.
1343 If MODE is t or `secret', only secret keyring should be searched.
1344 Otherwise, only public keyring should be searched and the key
1345 signatures should be included.
1346 NAME is either a string or a list of strings."
1347   (let ((lines (epg--list-keys-1 context name mode))
1348         keys cert pointer pointer-1 index string)
1349     (while lines
1350       (cond
1351        ((member (aref (car lines) 0) '("pub" "sec" "crt" "crs"))
1352         (setq cert (member (aref (car lines) 0) '("crt" "crs"))
1353               keys (cons (epg-make-key
1354                           (if (aref (car lines) 8)
1355                               (cdr (assq (string-to-char (aref (car lines) 8))
1356                                          epg-key-validity-alist))))
1357                          keys))
1358         (push (epg--make-sub-key-1 (car lines))
1359               (epg-key-sub-key-list (car keys))))
1360        ((member (aref (car lines) 0) '("sub" "ssb"))
1361         (push (epg--make-sub-key-1 (car lines))
1362               (epg-key-sub-key-list (car keys))))
1363        ((equal (aref (car lines) 0) "uid")
1364         ;; Decode the UID name as a backslash escaped UTF-8 string,
1365         ;; generated by GnuPG/GpgSM.
1366         (setq string (copy-sequence (aref (car lines) 9))
1367               index 0)
1368         (while (string-match "\"" string index)
1369           (setq string (replace-match "\\\"" t t string)
1370                 index (1+ (match-end 0))))
1371         (condition-case nil
1372             (setq string (epg--decode-coding-string
1373                           (car (read-from-string (concat "\"" string "\"")))
1374                           'utf-8))
1375           (error
1376            (setq string (aref (car lines) 9))))
1377         (push (epg-make-user-id
1378                (if (aref (car lines) 1)
1379                    (cdr (assq (string-to-char (aref (car lines) 1))
1380                               epg-key-validity-alist)))
1381                (if cert
1382                    (condition-case nil
1383                        (epg-dn-from-string string)
1384                      (error string))
1385                  string))
1386               (epg-key-user-id-list (car keys))))
1387        ((equal (aref (car lines) 0) "fpr")
1388         (setf (epg-sub-key-fingerprint (car (epg-key-sub-key-list (car keys))))
1389               (aref (car lines) 9)))
1390        ((equal (aref (car lines) 0) "sig")
1391         (push
1392          (epg-make-key-signature
1393           (if (aref (car lines) 1)
1394               (cdr (assq (string-to-char (aref (car lines) 1))
1395                          epg-key-validity-alist)))
1396           (string-to-number (aref (car lines) 3))
1397           (aref (car lines) 4)
1398           (epg--time-from-seconds (aref (car lines) 5))
1399           (epg--time-from-seconds (aref (car lines) 6))
1400           (aref (car lines) 9)
1401           (string-to-number (aref (car lines) 10) 16)
1402           (eq (aref (aref (car lines) 10) 2) ?x))
1403          (epg-user-id-signature-list
1404           (car (epg-key-user-id-list (car keys)))))))
1405       (setq lines (cdr lines)))
1406     (setq keys (nreverse keys)
1407           pointer keys)
1408     (while pointer
1409       (epg--gv-nreverse (epg-key-sub-key-list (car pointer)))
1410       (setq pointer-1 (epg--gv-nreverse (epg-key-user-id-list (car pointer))))
1411       (while pointer-1
1412         (epg--gv-nreverse (epg-user-id-signature-list (car pointer-1)))
1413         (setq pointer-1 (cdr pointer-1)))
1414       (setq pointer (cdr pointer)))
1415     keys))
1416
1417 (eval-and-compile
1418   (if (fboundp 'make-temp-file)
1419       (defalias 'epg--make-temp-file 'make-temp-file)
1420     (defvar temporary-file-directory)
1421     ;; stolen from poe.el.
1422     (defun epg--make-temp-file (prefix)
1423       "Create a temporary file.
1424 The returned file name (created by appending some random characters at the end
1425 of PREFIX, and expanding against `temporary-file-directory' if necessary),
1426 is guaranteed to point to a newly created empty file.
1427 You can then use `write-region' to write new data into the file."
1428       (let ((orig-modes (default-file-modes))
1429             tempdir tempfile)
1430         (setq prefix (expand-file-name prefix
1431                                        (if (featurep 'xemacs)
1432                                            (temp-directory)
1433                                          temporary-file-directory)))
1434         (unwind-protect
1435             (let (file)
1436               ;; First, create a temporary directory.
1437               (set-default-file-modes #o700)
1438               (while (condition-case ()
1439                          (progn
1440                            (setq tempdir (make-temp-name
1441                                           (concat
1442                                            (file-name-directory prefix)
1443                                            "DIR")))
1444                            ;; return nil or signal an error.
1445                            (make-directory tempdir))
1446                        ;; let's try again.
1447                        (file-already-exists t)))
1448               ;; Second, create a temporary file in the tempdir.
1449               ;; There *is* a race condition between `make-temp-name'
1450               ;; and `write-region', but we don't care it since we are
1451               ;; in a private directory now.
1452               (setq tempfile (make-temp-name (concat tempdir "/EMU")))
1453               (write-region "" nil tempfile nil 'silent)
1454               ;; Finally, make a hard-link from the tempfile.
1455               (while (condition-case ()
1456                          (progn
1457                            (setq file (make-temp-name prefix))
1458                            ;; return nil or signal an error.
1459                            (add-name-to-file tempfile file))
1460                        ;; let's try again.
1461                        (file-already-exists t)))
1462               file)
1463           (set-default-file-modes orig-modes)
1464           ;; Cleanup the tempfile.
1465           (and tempfile
1466                (file-exists-p tempfile)
1467                (delete-file tempfile))
1468           ;; Cleanup the tempdir.
1469           (and tempdir
1470                (file-directory-p tempdir)
1471                (delete-directory tempdir)))))))
1472
1473 (defun epg--args-from-sig-notations (notations)
1474   (apply #'nconc
1475          (mapcar
1476           (lambda (notation)
1477             (if (and (epg-sig-notation-name notation)
1478                      (not (epg-sig-notation-human-readable notation)))
1479                 (error "Unreadable"))
1480             (if (epg-sig-notation-name notation)
1481                 (list "--sig-notation"
1482                       (if (epg-sig-notation-critical notation)
1483                           (concat "!" (epg-sig-notation-name notation)
1484                                   "=" (epg-sig-notation-value notation))
1485                         (concat (epg-sig-notation-name notation)
1486                                 "=" (epg-sig-notation-value notation))))
1487               (list "--sig-policy-url"
1488                     (if (epg-sig-notation-critical notation)
1489                         (concat "!" (epg-sig-notation-value notation))
1490                       (epg-sig-notation-value notation)))))
1491           notations)))
1492
1493 (defun epg-cancel (context)
1494   (if (buffer-live-p (process-buffer (epg-context-process context)))
1495       (with-current-buffer (process-buffer (epg-context-process context))
1496         (epg-context-set-result-for
1497          epg-context 'error
1498          (cons '(quit)
1499                (epg-context-result-for epg-context 'error)))))
1500   (if (eq (process-status (epg-context-process context)) 'run)
1501       (delete-process (epg-context-process context))))
1502
1503 (defun epg-start-decrypt (context cipher)
1504   "Initiate a decrypt operation on CIPHER.
1505 CIPHER must be a file data object.
1506
1507 If you use this function, you will need to wait for the completion of
1508 `epg-gpg-program' by using `epg-wait-for-completion' and call
1509 `epg-reset' to clear a temporary output file.
1510 If you are unsure, use synchronous version of this function
1511 `epg-decrypt-file' or `epg-decrypt-string' instead."
1512   (unless (epg-data-file cipher)
1513     (error "Not a file"))
1514   (setf (epg-context-operation context) 'decrypt)
1515   (setf (epg-context-result context) nil)
1516   (epg--start context (list "--decrypt" "--" (epg-data-file cipher)))
1517   ;; `gpgsm' does not read passphrase from stdin, so waiting is not needed.
1518   (unless (eq (epg-context-protocol context) 'CMS)
1519     (epg-wait-for-status context '("BEGIN_DECRYPTION"))))
1520
1521 (defun epg--check-error-for-decrypt (context)
1522   (let ((errors (epg-context-result-for context 'error)))
1523     (if (epg-context-result-for context 'decryption-failed)
1524         (signal 'epg-error
1525                 (list "Decryption failed" (epg-errors-to-string errors))))
1526     (unless (epg-context-result-for context 'decryption-okay)
1527       (signal 'epg-error
1528               (list "Can't decrypt" (epg-errors-to-string errors))))))
1529
1530 (defun epg-decrypt-file (context cipher plain)
1531   "Decrypt a file CIPHER and store the result to a file PLAIN.
1532 If PLAIN is nil, it returns the result as a string."
1533   (unwind-protect
1534       (progn
1535         (setf (epg-context-output-file context)
1536               (or plain (epg--make-temp-file "epg-output")))
1537         (epg-start-decrypt context (epg-make-data-from-file cipher))
1538         (epg-wait-for-completion context)
1539         (epg--check-error-for-decrypt context)
1540         (unless plain
1541           (epg-read-output context)))
1542     (unless plain
1543       (epg-delete-output-file context))
1544     (epg-reset context)))
1545
1546 (defun epg-decrypt-string (context cipher)
1547   "Decrypt a string CIPHER and return the plain text."
1548   (let ((input-file (epg--make-temp-file "epg-input"))
1549         (coding-system-for-write 'binary))
1550     (unwind-protect
1551         (progn
1552           (write-region cipher nil input-file nil 'quiet)
1553           (setf (epg-context-output-file context)
1554                 (epg--make-temp-file "epg-output"))
1555           (epg-start-decrypt context (epg-make-data-from-file input-file))
1556           (epg-wait-for-completion context)
1557           (epg--check-error-for-decrypt context)
1558           (epg-read-output context))
1559       (epg-delete-output-file context)
1560       (if (file-exists-p input-file)
1561           (delete-file input-file))
1562       (epg-reset context))))
1563
1564 (defun epg-start-verify (context signature &optional signed-text)
1565   "Initiate a verify operation on SIGNATURE.
1566 SIGNATURE and SIGNED-TEXT are a data object if they are specified.
1567
1568 For a detached signature, both SIGNATURE and SIGNED-TEXT should be set.
1569 For a normal or a cleartext signature, SIGNED-TEXT should be nil.
1570
1571 If you use this function, you will need to wait for the completion of
1572 `epg-gpg-program' by using `epg-wait-for-completion' and call
1573 `epg-reset' to clear a temporary output file.
1574 If you are unsure, use synchronous version of this function
1575 `epg-verify-file' or `epg-verify-string' instead."
1576   (setf (epg-context-operation context) 'verify)
1577   (setf (epg-context-result context) nil)
1578   (if signed-text
1579       ;; Detached signature.
1580       (if (epg-data-file signed-text)
1581           (epg--start context (list "--verify" "--" (epg-data-file signature)
1582                                    (epg-data-file signed-text)))
1583         (epg--start context (list "--verify" "--" (epg-data-file signature)
1584                                   "-"))
1585         (if (eq (process-status (epg-context-process context)) 'run)
1586             (process-send-string (epg-context-process context)
1587                                  (epg-data-string signed-text)))
1588         (if (eq (process-status (epg-context-process context)) 'run)
1589             (process-send-eof (epg-context-process context))))
1590     ;; Normal (or cleartext) signature.
1591     (if (epg-data-file signature)
1592         (epg--start context (if (eq (epg-context-protocol context) 'CMS)
1593                                 (list "--verify" "--" (epg-data-file signature))
1594                               (list "--" (epg-data-file signature))))
1595       (epg--start context (if (eq (epg-context-protocol context) 'CMS)
1596                               '("--verify" "-")
1597                             '("-")))
1598       (if (eq (process-status (epg-context-process context)) 'run)
1599           (process-send-string (epg-context-process context)
1600                                (epg-data-string signature)))
1601       (if (eq (process-status (epg-context-process context)) 'run)
1602           (process-send-eof (epg-context-process context))))))
1603
1604 (defun epg-verify-file (context signature &optional signed-text plain)
1605   "Verify a file SIGNATURE.
1606 SIGNED-TEXT and PLAIN are also a file if they are specified.
1607
1608 For a detached signature, both SIGNATURE and SIGNED-TEXT should be
1609 string.  For a normal or a cleartext signature, SIGNED-TEXT should be
1610 nil.  In the latter case, if PLAIN is specified, the plaintext is
1611 stored into the file after successful verification.
1612
1613 Note that this function does not return verification result as t
1614 or nil, nor signal error on failure.  That's a design decision to
1615 handle the case where SIGNATURE has multiple signature.
1616
1617 To check the verification results, use `epg-context-result-for' as follows:
1618
1619 \(epg-context-result-for context \\='verify)
1620
1621 which will return a list of `epg-signature' object."
1622   (unwind-protect
1623       (progn
1624         (setf (epg-context-output-file context)
1625               (or plain (epg--make-temp-file "epg-output")))
1626         (if signed-text
1627             (epg-start-verify context
1628                               (epg-make-data-from-file signature)
1629                               (epg-make-data-from-file signed-text))
1630           (epg-start-verify context
1631                             (epg-make-data-from-file signature)))
1632         (epg-wait-for-completion context)
1633         (unless plain
1634           (epg-read-output context)))
1635     (unless plain
1636       (epg-delete-output-file context))
1637     (epg-reset context)))
1638
1639 (defun epg-verify-string (context signature &optional signed-text)
1640   "Verify a string SIGNATURE.
1641 SIGNED-TEXT is a string if it is specified.
1642
1643 For a detached signature, both SIGNATURE and SIGNED-TEXT should be
1644 string.  For a normal or a cleartext signature, SIGNED-TEXT should be
1645 nil.  In the latter case, this function returns the plaintext after
1646 successful verification.
1647
1648 Note that this function does not return verification result as t
1649 or nil, nor signal error on failure.  That's a design decision to
1650 handle the case where SIGNATURE has multiple signature.
1651
1652 To check the verification results, use `epg-context-result-for' as follows:
1653
1654 \(epg-context-result-for context \\='verify)
1655
1656 which will return a list of `epg-signature' object."
1657   (let ((coding-system-for-write 'binary)
1658         input-file)
1659     (unwind-protect
1660         (progn
1661           (setf (epg-context-output-file context)
1662                 (epg--make-temp-file "epg-output"))
1663           (if signed-text
1664               (progn
1665                 (setq input-file (epg--make-temp-file "epg-signature"))
1666                 (write-region signature nil input-file nil 'quiet)
1667                 (epg-start-verify context
1668                                   (epg-make-data-from-file input-file)
1669                                   (epg-make-data-from-string signed-text)))
1670             (epg-start-verify context (epg-make-data-from-string signature)))
1671           (epg-wait-for-completion context)
1672           (epg-read-output context))
1673       (epg-delete-output-file context)
1674       (if (and input-file
1675                (file-exists-p input-file))
1676           (delete-file input-file))
1677       (epg-reset context))))
1678
1679 (defun epg-start-sign (context plain &optional mode)
1680   "Initiate a sign operation on PLAIN.
1681 PLAIN is a data object.
1682
1683 If optional 3rd argument MODE is t or `detached', it makes a detached signature.
1684 If it is nil or `normal', it makes a normal signature.
1685 Otherwise, it makes a cleartext signature.
1686
1687 If you use this function, you will need to wait for the completion of
1688 `epg-gpg-program' by using `epg-wait-for-completion' and call
1689 `epg-reset' to clear a temporary output file.
1690 If you are unsure, use synchronous version of this function
1691 `epg-sign-file' or `epg-sign-string' instead."
1692   (setf (epg-context-operation context) 'sign)
1693   (setf (epg-context-result context) nil)
1694   (unless (memq mode '(t detached nil normal)) ;i.e. cleartext
1695     (epg-context-set-armor context nil)
1696     (epg-context-set-textmode context nil))
1697   (epg--start context
1698              (append (list (if (memq mode '(t detached))
1699                                "--detach-sign"
1700                              (if (memq mode '(nil normal))
1701                                  "--sign"
1702                                "--clearsign")))
1703                      (apply #'nconc
1704                             (mapcar
1705                              (lambda (signer)
1706                                (list "-u"
1707                                      (epg-sub-key-id
1708                                       (car (epg-key-sub-key-list signer)))))
1709                              (epg-context-signers context)))
1710                      (epg--args-from-sig-notations
1711                       (epg-context-sig-notations context))
1712                      (if (epg-data-file plain)
1713                          (list "--" (epg-data-file plain)))))
1714   ;; `gpgsm' does not read passphrase from stdin, so waiting is not needed.
1715   (unless (eq (epg-context-protocol context) 'CMS)
1716     (epg-wait-for-status context '("BEGIN_SIGNING")))
1717   (when (epg-data-string plain)
1718     (if (eq (process-status (epg-context-process context)) 'run)
1719         (process-send-string (epg-context-process context)
1720                              (epg-data-string plain)))
1721     (if (eq (process-status (epg-context-process context)) 'run)
1722         (process-send-eof (epg-context-process context)))))
1723
1724 (defun epg-sign-file (context plain signature &optional mode)
1725   "Sign a file PLAIN and store the result to a file SIGNATURE.
1726 If SIGNATURE is nil, it returns the result as a string.
1727 If optional 3rd argument MODE is t or `detached', it makes a detached signature.
1728 If it is nil or `normal', it makes a normal signature.
1729 Otherwise, it makes a cleartext signature."
1730   (unwind-protect
1731       (progn
1732         (setf (epg-context-output-file context)
1733               (or signature (epg--make-temp-file "epg-output")))
1734         (epg-start-sign context (epg-make-data-from-file plain) mode)
1735         (epg-wait-for-completion context)
1736         (unless (epg-context-result-for context 'sign)
1737           (let ((errors (epg-context-result-for context 'error)))
1738             (signal 'epg-error
1739                     (list "Sign failed" (epg-errors-to-string errors)))))
1740         (unless signature
1741           (epg-read-output context)))
1742     (unless signature
1743       (epg-delete-output-file context))
1744     (epg-reset context)))
1745
1746 (defun epg-sign-string (context plain &optional mode)
1747   "Sign a string PLAIN and return the output as string.
1748 If optional 3rd argument MODE is t or `detached', it makes a detached signature.
1749 If it is nil or `normal', it makes a normal signature.
1750 Otherwise, it makes a cleartext signature."
1751   (let ((input-file
1752          (unless (or (eq (epg-context-protocol context) 'CMS)
1753                      (condition-case nil
1754                          (progn
1755                            (epg-check-configuration (epg-configuration))
1756                            t)
1757                        (error)))
1758            (epg--make-temp-file "epg-input")))
1759         (coding-system-for-write 'binary))
1760     (unwind-protect
1761         (progn
1762           (setf (epg-context-output-file context)
1763                 (epg--make-temp-file "epg-output"))
1764           (if input-file
1765               (write-region plain nil input-file nil 'quiet))
1766           (epg-start-sign context
1767                           (if input-file
1768                               (epg-make-data-from-file input-file)
1769                             (epg-make-data-from-string plain))
1770                           mode)
1771           (epg-wait-for-completion context)
1772           (unless (epg-context-result-for context 'sign)
1773             (if (epg-context-result-for context 'error)
1774                 (let ((errors (epg-context-result-for context 'error)))
1775                   (signal 'epg-error
1776                           (list "Sign failed" (epg-errors-to-string errors))))))
1777           (epg-read-output context))
1778       (epg-delete-output-file context)
1779       (if input-file
1780           (delete-file input-file))
1781       (epg-reset context))))
1782
1783 (defun epg-start-encrypt (context plain recipients
1784                                   &optional sign always-trust)
1785   "Initiate an encrypt operation on PLAIN.
1786 PLAIN is a data object.
1787 If RECIPIENTS is nil, it performs symmetric encryption.
1788
1789 If you use this function, you will need to wait for the completion of
1790 `epg-gpg-program' by using `epg-wait-for-completion' and call
1791 `epg-reset' to clear a temporary output file.
1792 If you are unsure, use synchronous version of this function
1793 `epg-encrypt-file' or `epg-encrypt-string' instead."
1794   (setf (epg-context-operation context) 'encrypt)
1795   (setf (epg-context-result context) nil)
1796   (epg--start context
1797              (append (if always-trust '("--always-trust"))
1798                      (if recipients '("--encrypt") '("--symmetric"))
1799                      (if sign '("--sign"))
1800                      (if sign
1801                          (apply #'nconc
1802                                 (mapcar
1803                                  (lambda (signer)
1804                                    (list "-u"
1805                                          (epg-sub-key-id
1806                                           (car (epg-key-sub-key-list
1807                                                 signer)))))
1808                                  (epg-context-signers context))))
1809                      (if sign
1810                          (epg--args-from-sig-notations
1811                           (epg-context-sig-notations context)))
1812                      (apply #'nconc
1813                             (mapcar
1814                              (lambda (recipient)
1815                                (list "-r"
1816                                      (epg-sub-key-id
1817                                       (car (epg-key-sub-key-list recipient)))))
1818                              recipients))
1819                      (if (epg-data-file plain)
1820                          (list "--" (epg-data-file plain)))))
1821   ;; `gpgsm' does not read passphrase from stdin, so waiting is not needed.
1822   (unless (eq (epg-context-protocol context) 'CMS)
1823     (epg-wait-for-status context
1824                          (if sign '("BEGIN_SIGNING") '("BEGIN_ENCRYPTION"))))
1825   (when (epg-data-string plain)
1826     (if (eq (process-status (epg-context-process context)) 'run)
1827         (process-send-string (epg-context-process context)
1828                              (epg-data-string plain)))
1829     (if (eq (process-status (epg-context-process context)) 'run)
1830         (process-send-eof (epg-context-process context)))))
1831
1832 (defun epg-encrypt-file (context plain recipients
1833                                  cipher &optional sign always-trust)
1834   "Encrypt a file PLAIN and store the result to a file CIPHER.
1835 If CIPHER is nil, it returns the result as a string.
1836 If RECIPIENTS is nil, it performs symmetric encryption."
1837   (unwind-protect
1838       (progn
1839         (setf (epg-context-output-file context)
1840               (or cipher (epg--make-temp-file "epg-output")))
1841         (epg-start-encrypt context (epg-make-data-from-file plain)
1842                            recipients sign always-trust)
1843         (epg-wait-for-completion context)
1844         (let ((errors (epg-context-result-for context 'error)))
1845           (if (and sign
1846                    (not (epg-context-result-for context 'sign)))
1847               (signal 'epg-error
1848                       (list "Sign failed" (epg-errors-to-string errors))))
1849           (if errors
1850               (signal 'epg-error
1851                       (list "Encrypt failed" (epg-errors-to-string errors)))))
1852         (unless cipher
1853           (epg-read-output context)))
1854     (unless cipher
1855       (epg-delete-output-file context))
1856     (epg-reset context)))
1857
1858 (defun epg-encrypt-string (context plain recipients
1859                                    &optional sign always-trust)
1860   "Encrypt a string PLAIN.
1861 If RECIPIENTS is nil, it performs symmetric encryption."
1862   (let ((input-file
1863          (unless (or (not sign)
1864                      (eq (epg-context-protocol context) 'CMS)
1865                      (condition-case nil
1866                          (progn
1867                            (epg-check-configuration (epg-configuration))
1868                            t)
1869                        (error)))
1870            (epg--make-temp-file "epg-input")))
1871         (coding-system-for-write 'binary))
1872     (unwind-protect
1873         (progn
1874           (setf (epg-context-output-file context)
1875                 (epg--make-temp-file "epg-output"))
1876           (if input-file
1877               (write-region plain nil input-file nil 'quiet))
1878           (epg-start-encrypt context
1879                              (if input-file
1880                                  (epg-make-data-from-file input-file)
1881                                (epg-make-data-from-string plain))
1882                              recipients sign always-trust)
1883           (epg-wait-for-completion context)
1884           (let ((errors (epg-context-result-for context 'error)))
1885             (if (and sign
1886                      (not (epg-context-result-for context 'sign)))
1887                 (signal 'epg-error
1888                         (list "Sign failed" (epg-errors-to-string errors))))
1889             (if errors
1890                 (signal 'epg-error
1891                         (list "Encrypt failed" (epg-errors-to-string errors)))))
1892           (epg-read-output context))
1893       (epg-delete-output-file context)
1894       (if input-file
1895           (delete-file input-file))
1896       (epg-reset context))))
1897
1898 (defun epg-start-export-keys (context keys)
1899   "Initiate an export keys operation.
1900
1901 If you use this function, you will need to wait for the completion of
1902 `epg-gpg-program' by using `epg-wait-for-completion' and call
1903 `epg-reset' to clear a temporary output file.
1904 If you are unsure, use synchronous version of this function
1905 `epg-export-keys-to-file' or `epg-export-keys-to-string' instead."
1906   (setf (epg-context-operation context) 'export-keys)
1907   (setf (epg-context-result context) nil)
1908   (epg--start context (cons "--export"
1909                            (mapcar
1910                             (lambda (key)
1911                               (epg-sub-key-id
1912                                (car (epg-key-sub-key-list key))))
1913                             keys))))
1914
1915 (defun epg-export-keys-to-file (context keys file)
1916   "Extract public KEYS."
1917   (unwind-protect
1918       (progn
1919         (setf (epg-context-output-file context)
1920               (or file (epg--make-temp-file "epg-output")))
1921         (epg-start-export-keys context keys)
1922         (epg-wait-for-completion context)
1923         (let ((errors (epg-context-result-for context 'error)))
1924           (if errors
1925               (signal 'epg-error
1926                       (list "Export keys failed"
1927                             (epg-errors-to-string errors)))))
1928         (unless file
1929           (epg-read-output context)))
1930     (unless file
1931       (epg-delete-output-file context))
1932     (epg-reset context)))
1933
1934 (defun epg-export-keys-to-string (context keys)
1935   "Extract public KEYS and return them as a string."
1936   (epg-export-keys-to-file context keys nil))
1937
1938 (defun epg-start-import-keys (context keys)
1939   "Initiate an import keys operation.
1940 KEYS is a data object.
1941
1942 If you use this function, you will need to wait for the completion of
1943 `epg-gpg-program' by using `epg-wait-for-completion' and call
1944 `epg-reset' to clear a temporary output file.
1945 If you are unsure, use synchronous version of this function
1946 `epg-import-keys-from-file' or `epg-import-keys-from-string' instead."
1947   (setf (epg-context-operation context) 'import-keys)
1948   (setf (epg-context-result context) nil)
1949   (epg--start context (if (epg-data-file keys)
1950                           (list "--import" "--" (epg-data-file keys))
1951                         (list "--import")))
1952   (when (epg-data-string keys)
1953     (if (eq (process-status (epg-context-process context)) 'run)
1954         (process-send-string (epg-context-process context)
1955                              (epg-data-string keys)))
1956     (if (eq (process-status (epg-context-process context)) 'run)
1957         (process-send-eof (epg-context-process context)))))
1958
1959 (defun epg--import-keys-1 (context keys)
1960   (unwind-protect
1961       (progn
1962         (epg-start-import-keys context keys)
1963         (epg-wait-for-completion context)
1964         (let ((errors (epg-context-result-for context 'error)))
1965           (if errors
1966               (signal 'epg-error
1967                       (list "Import keys failed"
1968                             (epg-errors-to-string errors))))))
1969     (epg-reset context)))
1970
1971 (defun epg-import-keys-from-file (context keys)
1972   "Add keys from a file KEYS."
1973   (epg--import-keys-1 context (epg-make-data-from-file keys)))
1974
1975 (defun epg-import-keys-from-string (context keys)
1976   "Add keys from a string KEYS."
1977   (epg--import-keys-1 context (epg-make-data-from-string keys)))
1978
1979 (defun epg-start-receive-keys (context key-id-list)
1980   "Initiate a receive key operation.
1981 KEY-ID-LIST is a list of key IDs.
1982
1983 If you use this function, you will need to wait for the completion of
1984 `epg-gpg-program' by using `epg-wait-for-completion' and call
1985 `epg-reset' to clear a temporary output file.
1986 If you are unsure, use synchronous version of this function
1987 `epg-receive-keys' instead."
1988   (setf (epg-context-operation context) 'receive-keys)
1989   (setf (epg-context-result context) nil)
1990   (epg--start context (cons "--recv-keys" key-id-list)))
1991
1992 (defun epg-receive-keys (context keys)
1993   "Add keys from server.
1994 KEYS is a list of key IDs"
1995   (unwind-protect
1996       (progn
1997         (epg-start-receive-keys context keys)
1998         (epg-wait-for-completion context)
1999         (let ((errors (epg-context-result-for context 'error)))
2000           (if errors
2001               (signal 'epg-error
2002                       (list "Receive keys failed"
2003                             (epg-errors-to-string errors))))))
2004     (epg-reset context)))
2005
2006 (defalias 'epg-import-keys-from-server 'epg-receive-keys)
2007
2008 (defun epg-start-delete-keys (context keys &optional allow-secret)
2009   "Initiate a delete keys operation.
2010
2011 If you use this function, you will need to wait for the completion of
2012 `epg-gpg-program' by using `epg-wait-for-completion' and call
2013 `epg-reset' to clear a temporary output file.
2014 If you are unsure, use synchronous version of this function
2015 `epg-delete-keys' instead."
2016   (setf (epg-context-operation context) 'delete-keys)
2017   (setf (epg-context-result context) nil)
2018   (epg--start context (cons (if allow-secret
2019                                "--delete-secret-key"
2020                              "--delete-key")
2021                             (mapcar
2022                              (lambda (key)
2023                                (epg-sub-key-id
2024                                 (car (epg-key-sub-key-list key))))
2025                              keys))))
2026
2027 (defun epg-delete-keys (context keys &optional allow-secret)
2028   "Delete KEYS from the key ring."
2029   (unwind-protect
2030       (progn
2031         (epg-start-delete-keys context keys allow-secret)
2032         (epg-wait-for-completion context)
2033         (let ((errors (epg-context-result-for context 'error)))
2034           (if errors
2035               (signal 'epg-error
2036                       (list "Delete keys failed"
2037                             (epg-errors-to-string errors))))))
2038     (epg-reset context)))
2039
2040 (defun epg-start-sign-keys (context keys &optional local)
2041   "Initiate a sign keys operation.
2042
2043 If you use this function, you will need to wait for the completion of
2044 `epg-gpg-program' by using `epg-wait-for-completion' and call
2045 `epg-reset' to clear a temporary output file.
2046 If you are unsure, use synchronous version of this function
2047 `epg-sign-keys' instead."
2048   (declare (obsolete nil "23.1"))
2049   (setf (epg-context-operation context) 'sign-keys)
2050   (setf (epg-context-result context) nil)
2051   (epg--start context (cons (if local
2052                                "--lsign-key"
2053                              "--sign-key")
2054                            (mapcar
2055                             (lambda (key)
2056                               (epg-sub-key-id
2057                                (car (epg-key-sub-key-list key))))
2058                             keys))))
2059
2060 (defun epg-sign-keys (context keys &optional local)
2061   "Sign KEYS from the key ring."
2062   (declare (obsolete nil "23.1"))
2063   (unwind-protect
2064       (progn
2065         (epg-start-sign-keys context keys local)
2066         (epg-wait-for-completion context)
2067         (let ((errors (epg-context-result-for context 'error)))
2068           (if errors
2069               (signal 'epg-error
2070                       (list "Sign keys failed"
2071                             (epg-errors-to-string errors))))))
2072     (epg-reset context)))
2073
2074 (defun epg-start-generate-key (context parameters)
2075   "Initiate a key generation.
2076 PARAMETERS is a string which specifies parameters of the generated key.
2077 See Info node `(gnupg) Unattended GPG key generation' in the
2078 GnuPG manual for the format.
2079
2080 If you use this function, you will need to wait for the completion of
2081 `epg-gpg-program' by using `epg-wait-for-completion' and call
2082 `epg-reset' to clear a temporary output file.
2083 If you are unsure, use synchronous version of this function
2084 `epg-generate-key-from-file' or `epg-generate-key-from-string' instead."
2085   (setf (epg-context-operation context) 'generate-key)
2086   (setf (epg-context-result context) nil)
2087   (if (epg-data-file parameters)
2088       (epg--start context (list "--batch" "--gen-key" "--"
2089                                (epg-data-file parameters)))
2090     (epg--start context '("--batch" "--gen-key"))
2091     (if (eq (process-status (epg-context-process context)) 'run)
2092         (process-send-string (epg-context-process context)
2093                              (epg-data-string parameters)))
2094     (if (eq (process-status (epg-context-process context)) 'run)
2095         (process-send-eof (epg-context-process context)))))
2096
2097 (defun epg-generate-key-from-file (context parameters)
2098   "Generate a new key pair.
2099 PARAMETERS is a file which tells how to create the key."
2100   (unwind-protect
2101       (progn
2102         (epg-start-generate-key context (epg-make-data-from-file parameters))
2103         (epg-wait-for-completion context)
2104         (let ((errors (epg-context-result-for context 'error)))
2105           (if errors
2106               (signal 'epg-error
2107                       (list "Generate key failed"
2108                             (epg-errors-to-string errors))))))
2109     (epg-reset context)))
2110
2111 (defun epg-generate-key-from-string (context parameters)
2112   "Generate a new key pair.
2113 PARAMETERS is a string which tells how to create the key."
2114   (unwind-protect
2115       (progn
2116         (epg-start-generate-key context (epg-make-data-from-string parameters))
2117         (epg-wait-for-completion context)
2118         (let ((errors (epg-context-result-for context 'error)))
2119           (if errors
2120               (signal 'epg-error
2121                       (list "Generate key failed"
2122                             (epg-errors-to-string errors))))))
2123     (epg-reset context)))
2124
2125 (defun epg-start-edit-key (context key edit-callback handback)
2126   "Initiate an edit operation on KEY.
2127
2128 EDIT-CALLBACK is called from process filter and takes 3
2129 arguments: the context, a status, an argument string, and the
2130 handback argument.
2131
2132 If you use this function, you will need to wait for the completion of
2133 `epg-gpg-program' by using `epg-wait-for-completion' and call
2134 `epg-reset' to clear a temporary output file.
2135 If you are unsure, use synchronous version of this function
2136 `epg-edit-key' instead."
2137   (setf (epg-context-operation context) 'edit-key)
2138   (setf (epg-context-result context) nil)
2139   (setf (epg-context-edit-callback context) (cons edit-callback handback))
2140   (epg--start context (list "--edit-key"
2141                             (epg-sub-key-id
2142                              (car (epg-key-sub-key-list key))))))
2143
2144 (defun epg-edit-key (context key edit-callback handback)
2145   "Edit KEY in the keyring."
2146   (unwind-protect
2147       (progn
2148         (epg-start-edit-key context key edit-callback handback)
2149         (epg-wait-for-completion context)
2150         (let ((errors (epg-context-result-for context 'error)))
2151           (if errors
2152               (signal 'epg-error
2153                       (list "Edit key failed"
2154                             (epg-errors-to-string errors))))))
2155     (epg-reset context)))
2156
2157 (defun epg--decode-percent-escape (string)
2158   (let ((index 0))
2159     (while (string-match "%\\(\\(%\\)\\|\\([0-9A-Fa-f][0-9A-Fa-f]\\)\\)"
2160                          string index)
2161       (if (match-beginning 2)
2162           (setq string (replace-match "%" t t string)
2163                 index (1- (match-end 0)))
2164         (setq string (replace-match
2165                       (string (string-to-number (match-string 3 string) 16))
2166                       t t string)
2167               index (- (match-end 0) 2))))
2168     string))
2169
2170 (defun epg--decode-hexstring (string)
2171   (let ((index 0))
2172     (while (eq index (string-match "[0-9A-Fa-f][0-9A-Fa-f]" string index))
2173       (setq string (replace-match (string (string-to-number
2174                                            (match-string 0 string) 16))
2175                                   t t string)
2176             index (1- (match-end 0))))
2177     string))
2178
2179 (defun epg--decode-quotedstring (string)
2180   (let ((index 0))
2181     (while (string-match "\\\\\\(\\([,=+<>#;\\\"]\\)\\|\
2182 \\([0-9A-Fa-f][0-9A-Fa-f]\\)\\)"
2183                          string index)
2184       (if (match-beginning 2)
2185           (setq string (replace-match "\\2" t nil string)
2186                 index (1- (match-end 0)))
2187         (if (match-beginning 3)
2188             (setq string (replace-match (string (string-to-number
2189                                                  (match-string 0 string) 16))
2190                                         t t string)
2191                   index (- (match-end 0) 2)))))
2192     string))
2193
2194 (defun epg-dn-from-string (string)
2195   "Parse STRING as LADPv3 Distinguished Names (RFC2253).
2196 The return value is an alist mapping from types to values."
2197   (let ((index 0)
2198         (length (length string))
2199         alist type value group)
2200     (while (< index length)
2201       (if (eq index (string-match "[ \t\n\r]*" string index))
2202           (setq index (match-end 0)))
2203       (if (eq index (string-match
2204                      "\\([0-9]+\\(\\.[0-9]+\\)*\\)[ \t\n\r]*=[ \t\n\r]*"
2205                      string index))
2206           (setq type (match-string 1 string)
2207                 index (match-end 0))
2208         (if (eq index (string-match "\\([0-9A-Za-z]+\\)[ \t\n\r]*=[ \t\n\r]*"
2209                                     string index))
2210             (setq type (match-string 1 string)
2211                   index (match-end 0))))
2212       (unless type
2213         (error "Invalid type"))
2214       (if (eq index (string-match
2215                      "\\([^,=+<>#;\\\"]\\|\\\\.\\)+"
2216                      string index))
2217           (setq index (match-end 0)
2218                 value (epg--decode-quotedstring (match-string 0 string)))
2219         (if (eq index (string-match "#\\([0-9A-Fa-f]+\\)" string index))
2220             (setq index (match-end 0)
2221                   value (epg--decode-hexstring (match-string 1 string)))
2222           (if (eq index (string-match "\"\\([^\\\"]\\|\\\\.\\)*\""
2223                                       string index))
2224               (setq index (match-end 0)
2225                     value (epg--decode-quotedstring
2226                            (match-string 0 string))))))
2227       (if group
2228           (if (stringp (car (car alist)))
2229               (setcar alist (list (cons type value) (car alist)))
2230             (setcar alist (cons (cons type value) (car alist))))
2231         (if (consp (car (car alist)))
2232             (setcar alist (nreverse (car alist))))
2233         (setq alist (cons (cons type value) alist)
2234               type nil
2235               value nil))
2236       (if (eq index (string-match "[ \t\n\r]*\\([,;+]\\)" string index))
2237           (setq index (match-end 0)
2238                 group (eq (aref string (match-beginning 1)) ?+))))
2239     (nreverse alist)))
2240
2241 (defun epg-decode-dn (alist)
2242   "Convert ALIST returned by `epg-dn-from-string' to a human readable form.
2243 Type names are resolved using `epg-dn-type-alist'."
2244   (mapconcat
2245    (lambda (rdn)
2246      (if (stringp (car rdn))
2247          (let ((entry (assoc (car rdn) epg-dn-type-alist)))
2248            (if entry
2249                (format "%s=%s" (cdr entry) (cdr rdn))
2250              (format "%s=%s" (car rdn) (cdr rdn))))
2251        (concat "(" (epg-decode-dn rdn) ")")))
2252    alist
2253    ", "))
2254
2255 (provide 'epg)
2256
2257 ;;; epg.el ends here