X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=pgg-gpg.el;h=104dad0f5dc17b013cc11b83697e351981e69db6;hb=fdcad2c843f99ab9042ba6f493ddd79cd78789d8;hp=2bcb3c73ee69f2bb53cc84431df4d4e73fd371d3;hpb=f7deea13000b882c3141a3a0f42026f9a7c268cf;p=elisp%2Fsemi.git diff --git a/pgg-gpg.el b/pgg-gpg.el index 2bcb3c7..104dad0 100644 --- a/pgg-gpg.el +++ b/pgg-gpg.el @@ -1,8 +1,8 @@ ;;; pgg-gpg.el --- GnuPG support for PGG. -;; Copyright (C) 1999,2000 Daiki Ueno +;; Copyright (C) 1999,2000 Free Software Foundation, Inc. -;; Author: Daiki Ueno +;; Author: Daiki Ueno ;; Created: 1999/10/28 ;; Keywords: PGP, OpenPGP, GnuPG @@ -20,11 +20,12 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Code: +(require 'mel) ; binary-to-text-funcall (eval-when-compile (require 'pgg)) (defgroup pgg-gpg () @@ -36,17 +37,6 @@ :group 'pgg-gpg :type 'string) -(defcustom pgg-gpg-shell-file-name "/bin/sh" - "File name to load inferior shells from. Bourne shell or its equivalent -\(not tcsh) is needed for \"2>\"." - :group 'pgg-gpg - :type 'string) - -(defcustom pgg-gpg-shell-command-switch "-c" - "Switch used to have the shell execute its command line argument." - :group 'pgg-gpg - :type 'string) - (defcustom pgg-gpg-extra-args nil "Extra arguments for every GnuPG invocation." :group 'pgg-gpg @@ -58,6 +48,9 @@ (defvar pgg-gpg-user-id nil "GnuPG ID of your default identity.") +(defvar pgg-gpg-messages-locale pgg-messages-locale + "Locale set before running a GnuPG external process.") + (defvar pgg-scheme-gpg-instance nil) ;;;###autoload @@ -67,171 +60,161 @@ (luna-make-entity 'pgg-scheme-gpg)))) (defun pgg-gpg-process-region (start end passphrase program args) - (let* ((errors-file-name - (concat temporary-file-directory - (make-temp-name "pgg-errors"))) - (status-file-name - (concat temporary-file-directory - (make-temp-name "pgg-status"))) - (args - (append - `("--status-fd" "3" - ,@(if passphrase '("--passphrase-fd" "0")) - ,@pgg-gpg-extra-args) - args - (list (concat "2>" errors-file-name) - (concat "3>" status-file-name)))) - (shell-file-name pgg-gpg-shell-file-name) - (shell-command-switch pgg-gpg-shell-command-switch) + (let* ((output-file-name (make-temp-file + (expand-file-name "pgg-output" + temporary-file-directory))) + (args + `("--status-fd" "2" + ,@(if passphrase '("--passphrase-fd" "0")) + "--yes" ; overwrite + "--output" ,output-file-name + ,@pgg-gpg-extra-args ,@args)) (output-buffer pgg-output-buffer) (errors-buffer pgg-errors-buffer) - (status-buffer pgg-status-buffer) (process-connection-type nil) + (process-environment process-environment) process status exit-status) - (with-current-buffer (get-buffer-create output-buffer) + (when pgg-gpg-messages-locale + (setq process-environment (copy-sequence process-environment)) + (setenv "LC_ALL" pgg-gpg-messages-locale) + (setenv "LANGUAGE" pgg-gpg-messages-locale)) + (with-current-buffer (get-buffer-create errors-buffer) (buffer-disable-undo) (erase-buffer)) - (as-binary-process - (setq process - (apply #'start-process-shell-command "*GnuPG*" output-buffer - program args))) - (set-process-sentinel process #'ignore) - (when passphrase - (process-send-string process (concat passphrase "\n"))) - (process-send-region process start end) - (process-send-eof process) - (while (eq 'run (process-status process)) - (accept-process-output process 5)) - (setq status (process-status process) - exit-status (process-exit-status process)) - (delete-process process) - (with-current-buffer output-buffer - (pgg-convert-lbt-region (point-min)(point-max) 'LF) - - (if (memq status '(stop signal)) - (error "%s exited abnormally: '%s'" program exit-status)) - (if (= 127 exit-status) - (error "%s could not be found" program)) - - (set-buffer (get-buffer-create errors-buffer)) - (buffer-disable-undo) - (erase-buffer) - (insert-file-contents errors-file-name) - (delete-file errors-file-name) - - (set-buffer (get-buffer-create status-buffer)) - (buffer-disable-undo) - (erase-buffer) - (insert-file-contents status-file-name) - (delete-file status-file-name) - + (unwind-protect + (progn + (let ((coding-system-for-write 'binary)) + (setq process + (apply #'start-process "*GnuPG*" errors-buffer + program args))) + (set-process-sentinel process #'ignore) + (when passphrase + (process-send-string process (concat passphrase "\n"))) + (process-send-region process start end) + (process-send-eof process) + (while (eq 'run (process-status process)) + (accept-process-output process 5)) + (setq status (process-status process) + exit-status (process-exit-status process)) + (delete-process process) + (with-current-buffer (get-buffer-create output-buffer) + (buffer-disable-undo) + (erase-buffer) + (if (file-exists-p output-file-name) + (let ((coding-system-for-read 'raw-text-dos)) + (insert-file-contents output-file-name))) + (set-buffer errors-buffer) + (if (memq status '(stop signal)) + (error "%s exited abnormally: '%s'" program exit-status)) + (if (= 127 exit-status) + (error "%s could not be found" program)))) (if (and process (eq 'run (process-status process))) - (interrupt-process process))))) + (interrupt-process process)) + (if (file-exists-p output-file-name) + (delete-file output-file-name))))) + +(defun pgg-gpg-possibly-cache-passphrase (passphrase) + (if (and pgg-cache-passphrase + (progn + (goto-char (point-min)) + (re-search-forward "^\\[GNUPG:] GOOD_PASSPHRASE\\>" nil t))) + (pgg-add-passphrase-cache + (progn + (goto-char (point-min)) + (if (re-search-forward + "^\\[GNUPG:] NEED_PASSPHRASE \\w+ ?\\w*" nil t) + (substring (match-string 0) -8))) + passphrase))) (luna-define-method pgg-scheme-lookup-key ((scheme pgg-scheme-gpg) string &optional type) - (let ((args (list "--with-colons" "--no-greeting" "--batch" + (let ((args (list "--with-colons" "--no-greeting" "--batch" (if type "--list-secret-keys" "--list-keys") string))) - (with-current-buffer (get-buffer-create pgg-output-buffer) - (buffer-disable-undo) - (erase-buffer) + (with-temp-buffer (apply #'call-process pgg-gpg-program nil t nil args) (goto-char (point-min)) - (when (re-search-forward "^\\(sec\\|pub\\):" nil t) - (substring - (nth 3 (split-string - (buffer-substring (match-end 0) - (progn (end-of-line)(point))) - ":")) - 8))))) + (if (re-search-forward "^\\(sec\\|pub\\):[^:]*:[^:]*:[^:]*:\\([^:]*\\)" + nil t) + (substring (match-string 2) 8))))) -(luna-define-method pgg-scheme-encrypt-region ((scheme pgg-scheme-gpg) +(luna-define-method pgg-scheme-encrypt-region ((scheme pgg-scheme-gpg) start end recipients) - (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id)) - (args + (let* ((user-id (or pgg-overriding-user-id pgg-gpg-user-id + pgg-default-user-id)) + (args `("--batch" "--armor" "--always-trust" "--encrypt" ,@(if recipients - (apply #'append - (mapcar (lambda (rcpt) - (list "--remote-user" - (concat "\"" rcpt "\""))) + (apply #'nconc + (mapcar (lambda (rcpt) + (list "--remote-user" rcpt)) (append recipients (if pgg-encrypt-for-me - (list pgg-gpg-user-id))))))))) + (list user-id))))))))) (pgg-as-lbt start end 'CRLF (pgg-gpg-process-region start end nil pgg-gpg-program args)) - (pgg-process-when-success - (pgg-convert-lbt-region (point-min)(point-max) 'LF)))) + (pgg-process-when-success))) -(luna-define-method pgg-scheme-decrypt-region ((scheme pgg-scheme-gpg) +(luna-define-method pgg-scheme-decrypt-region ((scheme pgg-scheme-gpg) start end) - (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id)) + (let* ((user-id (or pgg-overriding-user-id pgg-gpg-user-id + pgg-default-user-id)) (passphrase - (pgg-read-passphrase + (pgg-read-passphrase (format "GnuPG passphrase for %s: " pgg-gpg-user-id) - (pgg-scheme-lookup-key scheme pgg-gpg-user-id 'encrypt))) + (pgg-scheme-lookup-key scheme user-id 'encrypt))) (args '("--batch" "--decrypt"))) (pgg-gpg-process-region start end passphrase pgg-gpg-program args) - (pgg-process-when-success nil))) + (with-current-buffer pgg-errors-buffer + (pgg-gpg-possibly-cache-passphrase passphrase) + (goto-char (point-min)) + (re-search-forward "^\\[GNUPG:] DECRYPTION_OKAY\\>" nil t)))) -(luna-define-method pgg-scheme-sign-region ((scheme pgg-scheme-gpg) +(luna-define-method pgg-scheme-sign-region ((scheme pgg-scheme-gpg) start end &optional cleartext) - (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id)) + (let* ((user-id (or pgg-overriding-user-id pgg-gpg-user-id + pgg-default-user-id)) (passphrase - (pgg-read-passphrase - (format "GnuPG passphrase for %s: " pgg-gpg-user-id) - (pgg-scheme-lookup-key scheme pgg-gpg-user-id 'sign))) - (args + (pgg-read-passphrase + (format "GnuPG passphrase for %s: " user-id) + (pgg-scheme-lookup-key scheme user-id 'sign))) + (args (list (if cleartext "--clearsign" "--detach-sign") - "--armor" "--batch" "--verbose" - "--local-user" pgg-gpg-user-id)) + "--armor" "--batch" "--verbose" + "--local-user" user-id)) (inhibit-read-only t) buffer-read-only) (pgg-as-lbt start end 'CRLF (pgg-gpg-process-region start end passphrase pgg-gpg-program args)) - (pgg-process-when-success - (pgg-convert-lbt-region (point-min)(point-max) 'LF) - (when (re-search-forward "^-+BEGIN PGP SIGNATURE" nil t);XXX - (let ((packet - (cdr (assq 2 (pgg-parse-armor-region - (progn (beginning-of-line 2) - (point)) - (point-max)))))) - (if pgg-cache-passphrase - (pgg-add-passphrase-cache - (cdr (assq 'key-identifier packet)) - passphrase))))))) + (with-current-buffer pgg-errors-buffer + (pgg-gpg-possibly-cache-passphrase passphrase)) + (pgg-process-when-success))) -(luna-define-method pgg-scheme-verify-region ((scheme pgg-scheme-gpg) +(luna-define-method pgg-scheme-verify-region ((scheme pgg-scheme-gpg) start end &optional signature) (let ((args '("--batch" "--verify"))) (when (stringp signature) (setq args (append args (list signature)))) + (setq args (append args '("-"))) (pgg-gpg-process-region start end nil pgg-gpg-program args) - (save-excursion - (set-buffer pgg-errors-buffer) + (with-current-buffer pgg-errors-buffer (goto-char (point-min)) (while (re-search-forward "^gpg: " nil t) (replace-match "")) (goto-char (point-min)) - (let ((case-fold-search t)) - (while (re-search-forward "^warning: " nil t) - (delete-region (match-beginning 0) - (progn (beginning-of-line 2) (point))))) - (set-buffer pgg-status-buffer) - (goto-char (point-min)) - (if (re-search-forward "^\\[GNUPG:] +GOODSIG +" nil t) - (progn - (set-buffer pgg-output-buffer) - (insert-buffer-substring pgg-errors-buffer) - t) - nil)))) + (prog1 (re-search-forward "^\\[GNUPG:] GOODSIG\\>" nil t) + (goto-char (point-min)) + (delete-matching-lines "^\\[GNUPG:] ") + ;; XXX: copy contents of pgg-errors-buffer into + ;; pgg-output-buffer for backward compatibility. + (with-current-buffer pgg-output-buffer + (set-buffer-multibyte t) + (insert-buffer-substring pgg-errors-buffer)))))) (luna-define-method pgg-scheme-insert-key ((scheme pgg-scheme-gpg)) - (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id)) - (args (list "--batch" "--export" "--armor" - (concat "\"" pgg-gpg-user-id "\"")))) + (let* ((user-id (or pgg-overriding-user-id pgg-gpg-user-id + pgg-default-user-id)) + (args (list "--batch" "--export" "--armor" user-id))) (pgg-gpg-process-region (point)(point) nil pgg-gpg-program args) (insert-buffer-substring pgg-output-buffer))) @@ -239,14 +222,12 @@ start end) (let ((args '("--import" "--batch" "-")) status) (pgg-gpg-process-region start end nil pgg-gpg-program args) - (set-buffer pgg-status-buffer) + (set-buffer pgg-errors-buffer) (goto-char (point-min)) - (when (re-search-forward "^\\[GNUPG:] +IMPORT_RES +" nil t) - (setq status (buffer-substring (match-end 0) - (progn (end-of-line) - (point))) - status (vconcat (mapcar #'string-to-int - (split-string status)))) + (when (re-search-forward "^\\[GNUPG:] IMPORT_RES\\>" nil t) + (setq status (buffer-substring (match-end 0) + (progn (end-of-line)(point))) + status (vconcat (mapcar #'string-to-int (split-string status)))) (erase-buffer) (insert (format "Imported %d key(s). \tArmor contains %d key(s) [%d bad, %d old].\n" @@ -258,10 +239,13 @@ (aref status 11))) (if (zerop (aref status 9)) "" - "\tSecret keys are imported.\n"))) - (append-to-buffer pgg-output-buffer - (point-min)(point-max)) - (pgg-process-when-success nil))) + "\tSecret keys are imported.\n")) + ;; XXX: copy contents of pgg-errors-buffer into + ;; pgg-output-buffer for backward compatibility. + (with-current-buffer pgg-output-buffer + (set-buffer-multibyte t) + (insert-buffer-substring pgg-errors-buffer)) + t))) (provide 'pgg-gpg)