X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/1bd71e9fe16541bc48868a00ff372018961380b0..c8bd285ff8c078d9f8cf59a0d530b62263e4a1c1:/lisp/epg.el

diff --git a/lisp/epg.el b/lisp/epg.el
index 3f04aa2e07..26e3b3d250 100644
--- a/lisp/epg.el
+++ b/lisp/epg.el
@@ -1,5 +1,5 @@
 ;;; epg.el --- the EasyPG Library -*- lexical-binding: t -*-
-;; Copyright (C) 1999-2000, 2002-2013 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2000, 2002-2014 Free Software Foundation, Inc.
 
 ;; Author: Daiki Ueno <ueno@unixuser.org>
 ;; Keywords: PGP, GnuPG
@@ -135,7 +135,7 @@
     (?f . full)
     (?u . ultimate)))
 
-(defvar epg-key-capablity-alist
+(defvar epg-key-capability-alist
   '((?e . encrypt)
     (?s . sign)
     (?c . certify)
@@ -162,8 +162,7 @@
 
 (defvar epg-prompt-alist nil)
 
-(put 'epg-error 'error-conditions '(epg-error error))
-(put 'epg-error 'error-message "GPG error")
+(define-error 'epg-error "GPG error")
 
 (defun epg-make-data-from-file (file)
   "Make a data object from FILE."
@@ -190,12 +189,21 @@
 				   cipher-algorithm digest-algorithm
 				   compress-algorithm)
   "Return a context object."
+  (unless protocol
+    (setq protocol 'OpenPGP))
+  (unless (memq protocol '(OpenPGP CMS))
+    (signal 'epg-error (list "unknown protocol" protocol)))
   (cons 'epg-context
-	(vector (or protocol 'OpenPGP) armor textmode include-certs
+	(vector protocol
+		(if (eq protocol 'OpenPGP)
+		    epg-gpg-program
+		  epg-gpgsm-program)
+		epg-gpg-home-directory
+		armor textmode include-certs
 		cipher-algorithm digest-algorithm compress-algorithm
 		(list #'epg-passphrase-callback-function)
 		nil
-		nil nil nil nil nil nil)))
+		nil nil nil nil nil nil nil)))
 
 (defun epg-context-protocol (context)
   "Return the protocol used within CONTEXT."
@@ -203,91 +211,109 @@
     (signal 'wrong-type-argument (list 'epg-context-p context)))
   (aref (cdr context) 0))
 
+(defun epg-context-program (context)
+  "Return the gpg or gpgsm executable used within CONTEXT."
+  (unless (eq (car-safe context) 'epg-context)
+    (signal 'wrong-type-argument (list 'epg-context-p context)))
+  (aref (cdr context) 1))
+
+(defun epg-context-home-directory (context)
+  "Return the GnuPG home directory used in CONTEXT."
+  (unless (eq (car-safe context) 'epg-context)
+    (signal 'wrong-type-argument (list 'epg-context-p context)))
+  (aref (cdr context) 2))
+
 (defun epg-context-armor (context)
   "Return t if the output should be ASCII armored in CONTEXT."
   (unless (eq (car-safe context) 'epg-context)
     (signal 'wrong-type-argument (list 'epg-context-p context)))
-  (aref (cdr context) 1))
+  (aref (cdr context) 3))
 
 (defun epg-context-textmode (context)
   "Return t if canonical text mode should be used in CONTEXT."
   (unless (eq (car-safe context) 'epg-context)
     (signal 'wrong-type-argument (list 'epg-context-p context)))
-  (aref (cdr context) 2))
+  (aref (cdr context) 4))
 
 (defun epg-context-include-certs (context)
   "Return how many certificates should be included in an S/MIME signed message."
   (unless (eq (car-safe context) 'epg-context)
     (signal 'wrong-type-argument (list 'epg-context-p context)))
-  (aref (cdr context) 3))
+  (aref (cdr context) 5))
 
 (defun epg-context-cipher-algorithm (context)
   "Return the cipher algorithm in CONTEXT."
   (unless (eq (car-safe context) 'epg-context)
     (signal 'wrong-type-argument (list 'epg-context-p context)))
-  (aref (cdr context) 4))
+  (aref (cdr context) 6))
 
 (defun epg-context-digest-algorithm (context)
   "Return the digest algorithm in CONTEXT."
   (unless (eq (car-safe context) 'epg-context)
     (signal 'wrong-type-argument (list 'epg-context-p context)))
-  (aref (cdr context) 5))
+  (aref (cdr context) 7))
 
 (defun epg-context-compress-algorithm (context)
   "Return the compress algorithm in CONTEXT."
   (unless (eq (car-safe context) 'epg-context)
     (signal 'wrong-type-argument (list 'epg-context-p context)))
-  (aref (cdr context) 6))
+  (aref (cdr context) 8))
 
 (defun epg-context-passphrase-callback (context)
   "Return the function used to query passphrase."
   (unless (eq (car-safe context) 'epg-context)
     (signal 'wrong-type-argument (list 'epg-context-p context)))
-  (aref (cdr context) 7))
+  (aref (cdr context) 9))
 
 (defun epg-context-progress-callback (context)
   "Return the function which handles progress update."
   (unless (eq (car-safe context) 'epg-context)
     (signal 'wrong-type-argument (list 'epg-context-p context)))
-  (aref (cdr context) 8))
+  (aref (cdr context) 10))
 
 (defun epg-context-signers (context)
   "Return the list of key-id for signing."
   (unless (eq (car-safe context) 'epg-context)
     (signal 'wrong-type-argument (list 'epg-context-p context)))
-  (aref (cdr context) 9))
+  (aref (cdr context) 11))
 
 (defun epg-context-sig-notations (context)
   "Return the list of notations for signing."
   (unless (eq (car-safe context) 'epg-context)
     (signal 'wrong-type-argument (list 'epg-context-p context)))
-  (aref (cdr context) 10))
+  (aref (cdr context) 12))
 
 (defun epg-context-process (context)
   "Return the process object of `epg-gpg-program'.
 This function is for internal use only."
   (unless (eq (car-safe context) 'epg-context)
     (signal 'wrong-type-argument (list 'epg-context-p context)))
-  (aref (cdr context) 11))
+  (aref (cdr context) 13))
 
 (defun epg-context-output-file (context)
   "Return the output file of `epg-gpg-program'.
 This function is for internal use only."
   (unless (eq (car-safe context) 'epg-context)
     (signal 'wrong-type-argument (list 'epg-context-p context)))
-  (aref (cdr context) 12))
+  (aref (cdr context) 14))
 
 (defun epg-context-result (context)
   "Return the result of the previous cryptographic operation."
   (unless (eq (car-safe context) 'epg-context)
     (signal 'wrong-type-argument (list 'epg-context-p context)))
-  (aref (cdr context) 13))
+  (aref (cdr context) 15))
 
 (defun epg-context-operation (context)
   "Return the name of the current cryptographic operation."
   (unless (eq (car-safe context) 'epg-context)
     (signal 'wrong-type-argument (list 'epg-context-p context)))
-  (aref (cdr context) 14))
+  (aref (cdr context) 16))
+
+(defun epg-context-pinentry-mode (context)
+  "Return the mode of pinentry invocation."
+  (unless (eq (car-safe context) 'epg-context)
+    (signal 'wrong-type-argument (list 'epg-context-p context)))
+  (aref (cdr context) 17))
 
 (defun epg-context-set-protocol (context protocol)
   "Set the protocol used within CONTEXT."
@@ -295,41 +321,53 @@ This function is for internal use only."
     (signal 'wrong-type-argument (list 'epg-context-p context)))
   (aset (cdr context) 0 protocol))
 
+(defun epg-context-set-program (context protocol)
+  "Set the gpg or gpgsm executable used within CONTEXT."
+  (unless (eq (car-safe context) 'epg-context)
+    (signal 'wrong-type-argument (list 'epg-context-p context)))
+  (aset (cdr context) 1 protocol))
+
+(defun epg-context-set-home-directory (context directory)
+  "Set the GnuPG home directory."
+  (unless (eq (car-safe context) 'epg-context)
+    (signal 'wrong-type-argument (list 'epg-context-p context)))
+  (aset (cdr context) 2 directory))
+
 (defun epg-context-set-armor (context armor)
   "Specify if the output should be ASCII armored in CONTEXT."
   (unless (eq (car-safe context) 'epg-context)
     (signal 'wrong-type-argument (list 'epg-context-p context)))
-  (aset (cdr context) 1 armor))
+  (aset (cdr context) 3 armor))
 
 (defun epg-context-set-textmode (context textmode)
   "Specify if canonical text mode should be used in CONTEXT."
   (unless (eq (car-safe context) 'epg-context)
     (signal 'wrong-type-argument (list 'epg-context-p context)))
-  (aset (cdr context) 2 textmode))
+  (aset (cdr context) 4 textmode))
 
 (defun epg-context-set-include-certs (context include-certs)
  "Set how many certificates should be included in an S/MIME signed message."
   (unless (eq (car-safe context) 'epg-context)
     (signal 'wrong-type-argument (list 'epg-context-p context)))
-  (aset (cdr context) 3 include-certs))
+  (aset (cdr context) 5 include-certs))
 
 (defun epg-context-set-cipher-algorithm (context cipher-algorithm)
  "Set the cipher algorithm in CONTEXT."
   (unless (eq (car-safe context) 'epg-context)
     (signal 'wrong-type-argument (list 'epg-context-p context)))
-  (aset (cdr context) 4 cipher-algorithm))
+  (aset (cdr context) 6 cipher-algorithm))
 
 (defun epg-context-set-digest-algorithm (context digest-algorithm)
  "Set the digest algorithm in CONTEXT."
   (unless (eq (car-safe context) 'epg-context)
     (signal 'wrong-type-argument (list 'epg-context-p context)))
-  (aset (cdr context) 5 digest-algorithm))
+  (aset (cdr context) 7 digest-algorithm))
 
 (defun epg-context-set-compress-algorithm (context compress-algorithm)
  "Set the compress algorithm in CONTEXT."
   (unless (eq (car-safe context) 'epg-context)
     (signal 'wrong-type-argument (list 'epg-context-p context)))
-  (aset (cdr context) 6 compress-algorithm))
+  (aset (cdr context) 8 compress-algorithm))
 
 (defun epg-context-set-passphrase-callback (context
 					    passphrase-callback)
@@ -348,7 +386,7 @@ installing GnuPG 1.x _along with_ GnuPG 2.x, which does passphrase
 query by itself and Emacs can intercept them."
   (unless (eq (car-safe context) 'epg-context)
     (signal 'wrong-type-argument (list 'epg-context-p context)))
-  (aset (cdr context) 7 (if (consp passphrase-callback)
+  (aset (cdr context) 9 (if (consp passphrase-callback)
 			    passphrase-callback
 			  (list passphrase-callback))))
 
@@ -365,7 +403,7 @@ current amount done, the total amount to be done, and the
 callback data (if any)."
   (unless (eq (car-safe context) 'epg-context)
     (signal 'wrong-type-argument (list 'epg-context-p context)))
-  (aset (cdr context) 8 (if (consp progress-callback)
+  (aset (cdr context) 10 (if (consp progress-callback)
 			    progress-callback
 			  (list progress-callback))))
 
@@ -373,39 +411,47 @@ callback data (if any)."
   "Set the list of key-id for signing."
   (unless (eq (car-safe context) 'epg-context)
     (signal 'wrong-type-argument (list 'epg-context-p context)))
-  (aset (cdr context) 9 signers))
+  (aset (cdr context) 11 signers))
 
 (defun epg-context-set-sig-notations (context notations)
   "Set the list of notations for signing."
   (unless (eq (car-safe context) 'epg-context)
     (signal 'wrong-type-argument (list 'epg-context-p context)))
-  (aset (cdr context) 10 notations))
+  (aset (cdr context) 12 notations))
 
 (defun epg-context-set-process (context process)
   "Set the process object of `epg-gpg-program'.
 This function is for internal use only."
   (unless (eq (car-safe context) 'epg-context)
     (signal 'wrong-type-argument (list 'epg-context-p context)))
-  (aset (cdr context) 11 process))
+  (aset (cdr context) 13 process))
 
 (defun epg-context-set-output-file (context output-file)
   "Set the output file of `epg-gpg-program'.
 This function is for internal use only."
   (unless (eq (car-safe context) 'epg-context)
     (signal 'wrong-type-argument (list 'epg-context-p context)))
-  (aset (cdr context) 12 output-file))
+  (aset (cdr context) 14 output-file))
 
 (defun epg-context-set-result (context result)
   "Set the result of the previous cryptographic operation."
   (unless (eq (car-safe context) 'epg-context)
     (signal 'wrong-type-argument (list 'epg-context-p context)))
-  (aset (cdr context) 13 result))
+  (aset (cdr context) 15 result))
 
 (defun epg-context-set-operation (context operation)
   "Set the name of the current cryptographic operation."
   (unless (eq (car-safe context) 'epg-context)
     (signal 'wrong-type-argument (list 'epg-context-p context)))
-  (aset (cdr context) 14 operation))
+  (aset (cdr context) 16 operation))
+
+(defun epg-context-set-pinentry-mode (context mode)
+  "Set the mode of pinentry invocation."
+  (unless (eq (car-safe context) 'epg-context)
+    (signal 'wrong-type-argument (list 'epg-context-p context)))
+  (unless (memq mode '(nil ask cancel error loopback))
+    (signal 'epg-error (list "Unknown pinentry mode" mode)))
+  (aset (cdr context) 17 mode))
 
 (defun epg-make-signature (status &optional key-id)
   "Return a signature object."
@@ -1078,7 +1124,7 @@ This function is for internal use only."
    ((eq (car error) 'exit)
     "Exit")
    ((eq (car error) 'quit)
-    "Cancelled")
+    "Canceled")
    ((eq (car error) 'no-data)
     (let ((entry (assq (cdr error) epg-no-data-reason-alist)))
       (if entry
@@ -1131,9 +1177,7 @@ This function is for internal use only."
   (if (and (epg-context-process context)
 	   (eq (process-status (epg-context-process context)) 'run))
       (error "%s is already running in this context"
-	     (if (eq (epg-context-protocol context) 'CMS)
-		 epg-gpgsm-program
-	       epg-gpg-program)))
+	     (epg-context-program context)))
   (let* ((agent-info (getenv "GPG_AGENT_INFO"))
 	 (args (append (list "--no-tty"
 			     "--status-fd" "1"
@@ -1144,20 +1188,24 @@ This function is for internal use only."
 		       (if (and (not (eq (epg-context-protocol context) 'CMS))
 				(epg-context-progress-callback context))
 			   '("--enable-progress-filter"))
-		       (if epg-gpg-home-directory
-			   (list "--homedir" epg-gpg-home-directory))
+		       (if (epg-context-home-directory context)
+			   (list "--homedir"
+				 (epg-context-home-directory context)))
 		       (unless (eq (epg-context-protocol context) 'CMS)
 			 '("--command-fd" "0"))
 		       (if (epg-context-armor context) '("--armor"))
 		       (if (epg-context-textmode context) '("--textmode"))
 		       (if (epg-context-output-file context)
 			   (list "--output" (epg-context-output-file context)))
+		       (if (epg-context-pinentry-mode context)
+			   (list "--pinentry-mode"
+				 (symbol-name (epg-context-pinentry-mode
+					       context))))
 		       args))
 	 (coding-system-for-write 'binary)
 	 (coding-system-for-read 'binary)
 	 process-connection-type
 	 (process-environment process-environment)
-	 (orig-mode (default-file-modes))
 	 (buffer (generate-new-buffer " *epg*"))
 	 process
 	 terminal-name
@@ -1195,9 +1243,7 @@ This function is for internal use only."
 		      (format "GPG_AGENT_INFO=%s\n" agent-info)
 		    "GPG_AGENT_INFO is not set\n")
 		  (format "%s %s\n"
-			  (if (eq (epg-context-protocol context) 'CMS)
-			      epg-gpgsm-program
-			   epg-gpg-program)
+			  (epg-context-program context)
 			  (mapconcat #'identity args " ")))))
     (with-current-buffer buffer
       (if (fboundp 'set-buffer-multibyte)
@@ -1218,52 +1264,42 @@ This function is for internal use only."
       (setq epg-agent-file agent-file)
       (make-local-variable 'epg-agent-mtime)
       (setq epg-agent-mtime agent-mtime))
-    (unwind-protect
-	(progn
-	  (set-default-file-modes 448)
-	  (setq process
-		(apply #'start-process "epg" buffer
-		       (if (eq (epg-context-protocol context) 'CMS)
-			   epg-gpgsm-program
-			 epg-gpg-program)
-		       args)))
-      (set-default-file-modes orig-mode))
+    (with-file-modes 448
+      (setq process (apply #'start-process "epg" buffer
+			   (epg-context-program context) args)))
     (set-process-filter process #'epg--process-filter)
     (epg-context-set-process context process)))
 
 (defun epg--process-filter (process input)
   (if epg-debug
-      (save-excursion
-	(unless epg-debug-buffer
-	  (setq epg-debug-buffer (generate-new-buffer " *epg-debug*")))
-	(set-buffer epg-debug-buffer)
+      (with-current-buffer
+          (or epg-debug-buffer
+              (setq epg-debug-buffer (generate-new-buffer " *epg-debug*")))
 	(goto-char (point-max))
 	(insert input)))
   (if (buffer-live-p (process-buffer process))
       (with-current-buffer (process-buffer process)
-	(goto-char (point-max))
-	(insert input)
-	(unless epg-process-filter-running
-	  (unwind-protect
-	      (progn
-		(setq epg-process-filter-running t)
-		(goto-char epg-read-point)
-		(beginning-of-line)
-		(while (looking-at ".*\n") ;the input line finished
-		  (if (looking-at "\\[GNUPG:] \\([A-Z_]+\\) ?\\(.*\\)")
-		      (let* ((status (match-string 1))
-			     (string (match-string 2))
-			     (symbol (intern-soft (concat "epg--status-"
-							  status))))
-			(if (member status epg-pending-status-list)
-			    (setq epg-pending-status-list nil))
-			(if (and symbol
-				 (fboundp symbol))
-			    (funcall symbol epg-context string))
-			(setq epg-last-status (cons status string))))
-		  (forward-line)
-		  (setq epg-read-point (point))))
-	    (setq epg-process-filter-running nil))))))
+        (save-excursion
+          (goto-char (point-max))
+          (insert input)
+          (unless epg-process-filter-running
+            (let ((epg-process-filter-running t))
+              (goto-char epg-read-point)
+              (beginning-of-line)
+              (while (looking-at ".*\n") ;the input line finished
+                (if (looking-at "\\[GNUPG:] \\([A-Z_]+\\) ?\\(.*\\)")
+                    (let* ((status (match-string 1))
+                           (string (match-string 2))
+                           (symbol (intern-soft (concat "epg--status-"
+                                                        status))))
+                      (if (member status epg-pending-status-list)
+                          (setq epg-pending-status-list nil))
+                      (if (and symbol
+                               (fboundp symbol))
+                          (funcall symbol epg-context string))
+                      (setq epg-last-status (cons status string))))
+                (forward-line)
+                (setq epg-read-point (point)))))))))
 
 (defun epg-read-output (context)
   "Read the output file CONTEXT and return the content as a string."
@@ -1300,7 +1336,7 @@ This function is for internal use only."
 	     (> (float-time (or (nth 5 (file-attributes epg-agent-file))
 				'(0 0 0 0)))
 		(float-time epg-agent-mtime))))
-      (redraw-frame (selected-frame)))
+      (redraw-frame))
   (epg-context-set-result-for
    context 'error
    (nreverse (epg-context-result-for context 'error))))
@@ -1836,8 +1872,9 @@ This function is for internal use only."
 	   (format "Passphrase for %s: " key-id)))))))
 
 (defun epg--list-keys-1 (context name mode)
-  (let ((args (append (if epg-gpg-home-directory
-			  (list "--homedir" epg-gpg-home-directory))
+  (let ((args (append (if (epg-context-home-directory context)
+			  (list "--homedir"
+				(epg-context-home-directory context)))
 		      '("--with-colons" "--no-greeting" "--batch"
 			"--with-fingerprint" "--with-fingerprint")
 		      (unless (eq (epg-context-protocol context) 'CMS)
@@ -1859,9 +1896,7 @@ This function is for internal use only."
       (setq args (append args (list list-keys-option))))
     (with-temp-buffer
       (apply #'call-process
-	     (if (eq (epg-context-protocol context) 'CMS)
-		 epg-gpgsm-program
-	       epg-gpg-program)
+	     (epg-context-program context)
 	     nil (list t nil) nil args)
       (goto-char (point-min))
       (while (re-search-forward "^[a-z][a-z][a-z]:.*" nil t)
@@ -1881,7 +1916,7 @@ This function is for internal use only."
    (if (aref line 1)
        (cdr (assq (string-to-char (aref line 1)) epg-key-validity-alist)))
    (delq nil
-	 (mapcar (lambda (char) (cdr (assq char epg-key-capablity-alist)))
+	 (mapcar (lambda (char) (cdr (assq char epg-key-capability-alist)))
 		 (aref line 11)))
    (member (aref line 0) '("sec" "ssb"))
    (string-to-number (aref line 3))
@@ -2178,7 +2213,17 @@ SIGNED-TEXT and PLAIN are also a file if they are specified.
 For a detached signature, both SIGNATURE and SIGNED-TEXT should be
 string.  For a normal or a cleartext signature, SIGNED-TEXT should be
 nil.  In the latter case, if PLAIN is specified, the plaintext is
-stored into the file after successful verification."
+stored into the file after successful verification.
+
+Note that this function does not return verification result as t
+or nil, nor signal error on failure.  That's a design decision to
+handle the case where SIGNATURE has multiple signature.
+
+To check the verification results, use `epg-context-result-for' as follows:
+
+\(epg-context-result-for context 'verify)
+
+which will return a list of `epg-signature' object."
   (unwind-protect
       (progn
 	(if plain
@@ -2205,7 +2250,17 @@ SIGNED-TEXT is a string if it is specified.
 For a detached signature, both SIGNATURE and SIGNED-TEXT should be
 string.  For a normal or a cleartext signature, SIGNED-TEXT should be
 nil.  In the latter case, this function returns the plaintext after
-successful verification."
+successful verification.
+
+Note that this function does not return verification result as t
+or nil, nor signal error on failure.  That's a design decision to
+handle the case where SIGNATURE has multiple signature.
+
+To check the verification results, use `epg-context-result-for' as follows:
+
+\(epg-context-result-for context 'verify)
+
+which will return a list of `epg-signature' object."
   (let ((coding-system-for-write 'binary)
 	input-file)
     (unwind-protect
@@ -2374,9 +2429,8 @@ If you are unsure, use synchronous version of this function
 			 (list "--" (epg-data-file plain)))))
   ;; `gpgsm' does not read passphrase from stdin, so waiting is not needed.
   (unless (eq (epg-context-protocol context) 'CMS)
-    (if sign
-	(epg-wait-for-status context '("BEGIN_SIGNING"))
-      (epg-wait-for-status context '("BEGIN_ENCRYPTION"))))
+    (epg-wait-for-status context
+                         (if sign '("BEGIN_SIGNING") '("BEGIN_ENCRYPTION"))))
   (when (epg-data-string plain)
     (if (eq (process-status (epg-context-process context)) 'run)
 	(process-send-string (epg-context-process context)