# HG changeset patch # User Daiki Ueno # Date 1292898636 -32400 # Node ID 62f897baec0a59b1f6050c7d57c574f8fb0b66c2 # Parent 7a4b15c4bbedf73d580cf9df280d2ca075dbf040 Mark PGG obsolete. * obsolete/pgg-parse.el, obsolete/pgg-pgp5.el, obsolete/pgg-pgp.el, * obsolete/pgg-gpg.el, obsolete/pgg-def.el, obsolete/pgg.el: Move from lisp/. * gnus/mml1991.el (pgg-sign-region, pgg-encrypt-region): * gnus/gnus-art.el (pgg-snarf-keys-region): Autoload since PGG is now obsolete in Emacs. diff -r 7a4b15c4bbed -r 62f897baec0a lisp/ChangeLog --- a/lisp/ChangeLog Mon Dec 20 22:12:30 2010 +0000 +++ b/lisp/ChangeLog Tue Dec 21 11:30:36 2010 +0900 @@ -1,3 +1,9 @@ +2010-12-21 Daiki Ueno + + * obsolete/pgg-parse.el, obsolete/pgg-pgp5.el, obsolete/pgg-pgp.el, + * obsolete/pgg-gpg.el, obsolete/pgg-def.el, obsolete/pgg.el: Move + from lisp/. + 2010-12-20 Leo * dnd.el (dnd-get-local-file-name): Unhex of file name shall diff -r 7a4b15c4bbed -r 62f897baec0a lisp/gnus/ChangeLog --- a/lisp/gnus/ChangeLog Mon Dec 20 22:12:30 2010 +0000 +++ b/lisp/gnus/ChangeLog Tue Dec 21 11:30:36 2010 +0900 @@ -1,3 +1,9 @@ +2010-12-21 Daiki Ueno + + * mml1991.el (pgg-sign-region, pgg-encrypt-region): + * gnus-art.el (pgg-snarf-keys-region): Autoload since PGG is now + obsolete in Emacs. + 2010-12-17 Lars Magne Ingebrigtsen * gnus-group.el (gnus-group-delete-articles): New command. diff -r 7a4b15c4bbed -r 62f897baec0a lisp/gnus/gnus-art.el --- a/lisp/gnus/gnus-art.el Mon Dec 20 22:12:30 2010 +0000 +++ b/lisp/gnus/gnus-art.el Tue Dec 21 11:30:36 2010 +0900 @@ -8086,6 +8086,7 @@ (Info-index-next 1))) nil))) +(autoload 'pgg-snarf-keys-region "pgg") ;; Called after pgg-snarf-keys-region, which autoloads pgg.el. (declare-function pgg-display-output-buffer "pgg" (start end status)) diff -r 7a4b15c4bbed -r 62f897baec0a lisp/gnus/mml1991.el --- a/lisp/gnus/mml1991.el Mon Dec 20 22:12:30 2010 +0000 +++ b/lisp/gnus/mml1991.el Tue Dec 21 11:30:36 2010 +0900 @@ -168,6 +168,9 @@ ;; pgg wrapper +(autoload 'pgg-sign-region "pgg") +(autoload 'pgg-encrypt-region "pgg") + (defvar pgg-default-user-id) (defvar pgg-errors-buffer) (defvar pgg-output-buffer) diff -r 7a4b15c4bbed -r 62f897baec0a lisp/obsolete/pgg-def.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/obsolete/pgg-def.el Tue Dec 21 11:30:36 2010 +0900 @@ -0,0 +1,98 @@ +;;; pgg-def.el --- functions/macros for defining PGG functions + +;; Copyright (C) 1999, 2002, 2003, 2004, 2005, +;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. + +;; Author: Daiki Ueno +;; Created: 1999/11/02 +;; Keywords: PGP, OpenPGP, GnuPG +;; Package: pgg + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(defgroup pgg () + "Glue for the various PGP implementations." + :group 'mime + :version "22.1") + +(defcustom pgg-default-scheme 'gpg + "Default PGP scheme." + :group 'pgg + :type '(choice (const :tag "GnuPG" gpg) + (const :tag "PGP 5" pgp5) + (const :tag "PGP" pgp))) + +(defcustom pgg-default-user-id (user-login-name) + "User ID of your default identity." + :group 'pgg + :type 'string) + +(defcustom pgg-default-keyserver-address "subkeys.pgp.net" + "Host name of keyserver." + :group 'pgg + :type 'string) + +(defcustom pgg-query-keyserver nil + "Whether PGG queries keyservers for missing keys when verifying messages." + :version "22.1" + :group 'pgg + :type 'boolean) + +(defcustom pgg-encrypt-for-me t + "If t, encrypt all outgoing messages with user's public key." + :group 'pgg + :type 'boolean) + +(defcustom pgg-cache-passphrase t + "If t, cache passphrase." + :group 'pgg + :type 'boolean) + +(defcustom pgg-passphrase-cache-expiry 16 + "How many seconds the passphrase is cached. +Whether the passphrase is cached at all is controlled by +`pgg-cache-passphrase'." + :group 'pgg + :type 'integer) + +(defcustom pgg-passphrase-coding-system nil + "Coding system to encode passphrase." + :group 'pgg + :type 'coding-system) + +(defvar pgg-messages-coding-system nil + "Coding system used when reading from a PGP external process.") + +(defvar pgg-status-buffer " *PGG status*") +(defvar pgg-errors-buffer " *PGG errors*") +(defvar pgg-output-buffer " *PGG output*") + +(defvar pgg-echo-buffer "*PGG-echo*") + +(defvar pgg-scheme nil + "Current scheme of PGP implementation.") + +(defvar pgg-text-mode nil + "If t, inform the recipient that the input is text.") + +(defmacro pgg-truncate-key-identifier (key) + `(if (> (length ,key) 8) (substring ,key -8) ,key)) + +(provide 'pgg-def) + +;;; pgg-def.el ends here diff -r 7a4b15c4bbed -r 62f897baec0a lisp/obsolete/pgg-gpg.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/obsolete/pgg-gpg.el Tue Dec 21 11:30:36 2010 +0900 @@ -0,0 +1,410 @@ +;;; pgg-gpg.el --- GnuPG support for PGG. + +;; Copyright (C) 1999, 2000, 2002, 2003, 2004, +;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. + +;; Author: Daiki Ueno +;; Symmetric encryption and gpg-agent support added by: +;; Sascha Wilde +;; Created: 1999/10/28 +;; Keywords: PGP, OpenPGP, GnuPG +;; Package: pgg + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(eval-when-compile + (require 'cl) ; for gpg macros + (require 'pgg)) + +(defgroup pgg-gpg () + "GnuPG interface." + :group 'pgg) + +(defcustom pgg-gpg-program "gpg" + "The GnuPG executable." + :group 'pgg-gpg + :type 'string) + +(defcustom pgg-gpg-extra-args nil + "Extra arguments for every GnuPG invocation." + :group 'pgg-gpg + :type '(repeat (string :tag "Argument"))) + +(defcustom pgg-gpg-recipient-argument "--recipient" + "GnuPG option to specify recipient." + :group 'pgg-gpg + :type '(choice (const :tag "New `--recipient' option" "--recipient") + (const :tag "Old `--remote-user' option" "--remote-user"))) + +(defcustom pgg-gpg-use-agent t + "Whether to use gnupg agent for key caching." + :group 'pgg-gpg + :type 'boolean) + +(defvar pgg-gpg-user-id nil + "GnuPG ID of your default identity.") + +(defun pgg-gpg-process-region (start end passphrase program args) + (let* ((use-agent (and (null passphrase) (pgg-gpg-use-agent-p))) + (output-file-name (pgg-make-temp-file "pgg-output")) + (args + `("--status-fd" "2" + ,@(if use-agent '("--use-agent") + (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) + (orig-mode (default-file-modes)) + (process-connection-type nil) + (inhibit-redisplay t) + process status exit-status + passphrase-with-newline + encoded-passphrase-with-new-line) + (with-current-buffer (get-buffer-create errors-buffer) + (buffer-disable-undo) + (erase-buffer)) + (unwind-protect + (progn + (set-default-file-modes 448) + (let ((coding-system-for-write 'binary)) + (setq process + (apply #'start-process "*GnuPG*" errors-buffer + program args))) + (set-process-sentinel process #'ignore) + (when passphrase + (setq passphrase-with-newline (concat passphrase "\n")) + (if pgg-passphrase-coding-system + (progn + (setq encoded-passphrase-with-new-line + (encode-coding-string + passphrase-with-newline + (coding-system-change-eol-conversion + pgg-passphrase-coding-system 'unix))) + (pgg-clear-string passphrase-with-newline)) + (setq encoded-passphrase-with-new-line passphrase-with-newline + passphrase-with-newline nil)) + (process-send-string process encoded-passphrase-with-new-line)) + (process-send-region process start end) + (process-send-eof process) + (while (eq 'run (process-status process)) + (accept-process-output process 5)) + ;; Accept any remaining pending output coming after the + ;; status change. + (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 (if pgg-text-mode + 'raw-text + 'binary))) + (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 passphrase-with-newline + (pgg-clear-string passphrase-with-newline)) + (if encoded-passphrase-with-new-line + (pgg-clear-string encoded-passphrase-with-new-line)) + (if (and process (eq 'run (process-status process))) + (interrupt-process process)) + (if (file-exists-p output-file-name) + (delete-file output-file-name)) + (set-default-file-modes orig-mode)))) + +(defun pgg-gpg-possibly-cache-passphrase (passphrase &optional key notruncate) + (if (and passphrase + pgg-cache-passphrase + (progn + (goto-char (point-min)) + (re-search-forward "^\\[GNUPG:] \\(GOOD_PASSPHRASE\\>\\)\\|\\(SIG_CREATED\\)" nil t))) + (pgg-add-passphrase-to-cache + (or key + (progn + (goto-char (point-min)) + (if (re-search-forward + "^\\[GNUPG:] NEED_PASSPHRASE\\(_PIN\\)? \\w+ ?\\w*" nil t) + (substring (match-string 0) -8)))) + passphrase + notruncate))) + +(defvar pgg-gpg-all-secret-keys 'unknown) + +(defun pgg-gpg-lookup-all-secret-keys () + "Return all secret keys present in secret key ring." + (when (eq pgg-gpg-all-secret-keys 'unknown) + (setq pgg-gpg-all-secret-keys '()) + (let ((args (list "--with-colons" "--no-greeting" "--batch" + "--list-secret-keys"))) + (with-temp-buffer + (apply #'call-process pgg-gpg-program nil t nil args) + (goto-char (point-min)) + (while (re-search-forward + "^\\(sec\\|pub\\):[^:]*:[^:]*:[^:]*:\\([^:]*\\)" nil t) + (push (substring (match-string 2) 8) + pgg-gpg-all-secret-keys))))) + pgg-gpg-all-secret-keys) + +(defun pgg-gpg-lookup-key (string &optional type) + "Search keys associated with STRING." + (let ((args (list "--with-colons" "--no-greeting" "--batch" + (if type "--list-secret-keys" "--list-keys") + string))) + (with-temp-buffer + (apply #'call-process pgg-gpg-program nil t nil args) + (goto-char (point-min)) + (if (re-search-forward "^\\(sec\\|pub\\):[^:]*:[^:]*:[^:]*:\\([^:]*\\)" + nil t) + (substring (match-string 2) 8))))) + +(defun pgg-gpg-lookup-key-owner (string &optional all) + "Search keys associated with STRING and return owner of identified key. + +The value may be just the bare key id, or it may be a combination of the +user name associated with the key and the key id, with the key id enclosed +in \"<...>\" angle brackets. + +Optional ALL non-nil means search all keys, including secret keys." + (let ((args (list "--with-colons" "--no-greeting" "--batch" + (if all "--list-secret-keys" "--list-keys") + string)) + (key-regexp (concat "^\\(sec\\|pub\\|uid\\)" + ":[^:]*:[^:]*:[^:]*:\\([^:]*\\):[^:]*" + ":[^:]*:[^:]*:[^:]*:\\([^:]+\\):"))) + (with-temp-buffer + (apply #'call-process pgg-gpg-program nil t nil args) + (goto-char (point-min)) + (if (re-search-forward key-regexp + nil t) + (match-string 3))))) + +(defun pgg-gpg-key-id-from-key-owner (key-owner) + (cond ((not key-owner) nil) + ;; Extract bare key id from outermost paired angle brackets, if any: + ((string-match "[^<]*<\\(.+\\)>[^>]*" key-owner) + (substring key-owner (match-beginning 1)(match-end 1))) + (key-owner))) + +(defun pgg-gpg-encrypt-region (start end recipients &optional sign passphrase) + "Encrypt the current region between START and END. + +If optional argument SIGN is non-nil, do a combined sign and encrypt. + +If optional PASSPHRASE is not specified, it will be obtained from the +passphrase cache or user." + (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id)) + (passphrase (or passphrase + (when (and sign (not (pgg-gpg-use-agent-p))) + (pgg-read-passphrase + (format "GnuPG passphrase for %s: " + pgg-gpg-user-id) + pgg-gpg-user-id)))) + (args + (append + (list "--batch" "--armor" "--always-trust" "--encrypt") + (if pgg-text-mode (list "--textmode")) + (if sign (list "--sign" "--local-user" pgg-gpg-user-id)) + (if (or recipients pgg-encrypt-for-me) + (apply #'nconc + (mapcar (lambda (rcpt) + (list pgg-gpg-recipient-argument rcpt)) + (append recipients + (if pgg-encrypt-for-me + (list pgg-gpg-user-id))))))))) + (pgg-gpg-process-region start end passphrase pgg-gpg-program args) + (when sign + (with-current-buffer pgg-errors-buffer + ;; Possibly cache passphrase under, e.g. "jas", for future sign. + (pgg-gpg-possibly-cache-passphrase passphrase pgg-gpg-user-id) + ;; Possibly cache passphrase under, e.g. B565716F, for future decrypt. + (pgg-gpg-possibly-cache-passphrase passphrase))) + (pgg-process-when-success))) + +(defun pgg-gpg-encrypt-symmetric-region (start end &optional passphrase) + "Encrypt the current region between START and END with symmetric cipher. + +If optional PASSPHRASE is not specified, it will be obtained from the +passphrase cache or user." + (let* ((passphrase (or passphrase + (when (not (pgg-gpg-use-agent-p)) + (pgg-read-passphrase + "GnuPG passphrase for symmetric encryption: ")))) + (args + (append (list "--batch" "--armor" "--symmetric" ) + (if pgg-text-mode (list "--textmode"))))) + (pgg-gpg-process-region start end passphrase pgg-gpg-program args) + (pgg-process-when-success))) + +(defun pgg-gpg-decrypt-region (start end &optional passphrase) + "Decrypt the current region between START and END. + +If optional PASSPHRASE is not specified, it will be obtained from the +passphrase cache or user." + (let* ((current-buffer (current-buffer)) + (message-keys (with-temp-buffer + (insert-buffer-substring current-buffer) + (pgg-decode-armor-region (point-min) (point-max)))) + (secret-keys (pgg-gpg-lookup-all-secret-keys)) + ;; XXX the user is stuck if they need to use the passphrase for + ;; any but the first secret key for which the message is + ;; encrypted. ideally, we would incrementally give them a + ;; chance with subsequent keys each time they fail with one. + (key (pgg-gpg-select-matching-key message-keys secret-keys)) + (key-owner (and key (pgg-gpg-lookup-key-owner key t))) + (key-id (pgg-gpg-key-id-from-key-owner key-owner)) + (pgg-gpg-user-id (or key-id key + pgg-gpg-user-id pgg-default-user-id)) + (passphrase (or passphrase + (when (not (pgg-gpg-use-agent-p)) + (pgg-read-passphrase + (format (if (pgg-gpg-symmetric-key-p message-keys) + "Passphrase for symmetric decryption: " + "GnuPG passphrase for %s: ") + (or key-owner "??")) + pgg-gpg-user-id)))) + (args '("--batch" "--decrypt"))) + (pgg-gpg-process-region start end passphrase pgg-gpg-program args) + (with-current-buffer pgg-errors-buffer + (pgg-gpg-possibly-cache-passphrase passphrase pgg-gpg-user-id) + (goto-char (point-min)) + (re-search-forward "^\\[GNUPG:] DECRYPTION_OKAY\\>" nil t)))) + +;;;###autoload +(defun pgg-gpg-symmetric-key-p (message-keys) + "True if decoded armor MESSAGE-KEYS has symmetric encryption indicator." + (let (result) + (dolist (key message-keys result) + (when (and (eq (car key) 3) + (member '(symmetric-key-algorithm) key)) + (setq result key))))) + +(defun pgg-gpg-select-matching-key (message-keys secret-keys) + "Choose a key from MESSAGE-KEYS that matches one of the keys in SECRET-KEYS." + (loop for message-key in message-keys + for message-key-id = (and (equal (car message-key) 1) + (cdr (assq 'key-identifier + (cdr message-key)))) + for key = (and message-key-id (pgg-lookup-key message-key-id 'encrypt)) + when (and key (member key secret-keys)) return key)) + +(defun pgg-gpg-sign-region (start end &optional cleartext passphrase) + "Make detached signature from text between START and END." + (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id)) + (passphrase (or passphrase + (when (not (pgg-gpg-use-agent-p)) + (pgg-read-passphrase + (format "GnuPG passphrase for %s: " + pgg-gpg-user-id) + pgg-gpg-user-id)))) + (args + (append (list (if cleartext "--clearsign" "--detach-sign") + "--armor" "--batch" "--verbose" + "--local-user" pgg-gpg-user-id) + (if pgg-text-mode (list "--textmode")))) + (inhibit-read-only t) + buffer-read-only) + (pgg-gpg-process-region start end passphrase pgg-gpg-program args) + (with-current-buffer pgg-errors-buffer + ;; Possibly cache passphrase under, e.g. "jas", for future sign. + (pgg-gpg-possibly-cache-passphrase passphrase pgg-gpg-user-id) + ;; Possibly cache passphrase under, e.g. B565716F, for future decrypt. + (pgg-gpg-possibly-cache-passphrase passphrase)) + (pgg-process-when-success))) + +(defun pgg-gpg-verify-region (start end &optional signature) + "Verify region between START and END as the detached signature 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) + (with-current-buffer pgg-errors-buffer + (goto-char (point-min)) + (while (re-search-forward "^gpg: \\(.*\\)\n" nil t) + (with-current-buffer pgg-output-buffer + (insert-buffer-substring pgg-errors-buffer + (match-beginning 1) (match-end 0))) + (delete-region (match-beginning 0) (match-end 0))) + (goto-char (point-min)) + (re-search-forward "^\\[GNUPG:] GOODSIG\\>" nil t)))) + +(defun pgg-gpg-insert-key () + "Insert public key at point." + (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id)) + (args (list "--batch" "--export" "--armor" + pgg-gpg-user-id))) + (pgg-gpg-process-region (point)(point) nil pgg-gpg-program args) + (insert-buffer-substring pgg-output-buffer))) + +(defun pgg-gpg-snarf-keys-region (start end) + "Add all public keys in region between START and END to the keyring." + (let ((args '("--import" "--batch" "-")) status) + (pgg-gpg-process-region start end nil pgg-gpg-program args) + (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-number (split-string status)))) + (erase-buffer) + (insert (format "Imported %d key(s). +\tArmor contains %d key(s) [%d bad, %d old].\n" + (+ (aref status 2) + (aref status 10)) + (aref status 0) + (aref status 1) + (+ (aref status 4) + (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))) + +(defun pgg-gpg-update-agent () + "Try to connet to gpg-agent and send UPDATESTARTUPTTY." + (if (fboundp 'make-network-process) + (let* ((agent-info (getenv "GPG_AGENT_INFO")) + (socket (and agent-info + (string-match "^\\([^:]*\\)" agent-info) + (match-string 1 agent-info))) + (conn (and socket + (make-network-process :name "gpg-agent-process" + :host 'local :family 'local + :service socket)))) + (when (and conn (eq (process-status conn) 'open)) + (process-send-string conn "UPDATESTARTUPTTY\n") + (delete-process conn) + t)) + ;; We can't check, so assume gpg-agent is up. + t)) + +(defun pgg-gpg-use-agent-p () + "Return t if `pgg-gpg-use-agent' is t and gpg-agent is available." + (and pgg-gpg-use-agent (pgg-gpg-update-agent))) + +(provide 'pgg-gpg) + +;;; pgg-gpg.el ends here diff -r 7a4b15c4bbed -r 62f897baec0a lisp/obsolete/pgg-parse.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/obsolete/pgg-parse.el Tue Dec 21 11:30:36 2010 +0900 @@ -0,0 +1,523 @@ +;;; pgg-parse.el --- OpenPGP packet parsing + +;; Copyright (C) 1999, 2002, 2003, 2004, 2005, +;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. + +;; Author: Daiki Ueno +;; Created: 1999/10/28 +;; Keywords: PGP, OpenPGP, GnuPG +;; Package: pgg + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; This module is based on + +;; [OpenPGP] RFC 2440: "OpenPGP Message Format" +;; by John W. Noerenberg, II , +;; Jon Callas , Lutz Donnerhacke , +;; Hal Finney and Rodney Thayer +;; (1998/11) + +;;; Code: + +(eval-when-compile + ;; For Emacs <22.2 and XEmacs. + (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))) + (require 'cl)) + +(defgroup pgg-parse () + "OpenPGP packet parsing." + :group 'pgg) + +(defcustom pgg-parse-public-key-algorithm-alist + '((1 . RSA) (2 . RSA-E) (3 . RSA-S) (16 . ELG-E) (17 . DSA) (20 . ELG)) + "Alist of the assigned number to the public key algorithm." + :group 'pgg-parse + :type '(repeat + (cons (sexp :tag "Number") (sexp :tag "Type")))) + +(defcustom pgg-parse-symmetric-key-algorithm-alist + '((1 . IDEA) (2 . 3DES) (4 . CAST5) (5 . SAFER-SK128)) + "Alist of the assigned number to the simmetric key algorithm." + :group 'pgg-parse + :type '(repeat + (cons (sexp :tag "Number") (sexp :tag "Type")))) + +(defcustom pgg-parse-hash-algorithm-alist + '((1 . MD5) (2 . SHA1) (3 . RIPEMD160) (5 . MD2) (8 . SHA256) (9 . SHA384) + (10 . SHA512)) + "Alist of the assigned number to the cryptographic hash algorithm." + :group 'pgg-parse + :type '(repeat + (cons (sexp :tag "Number") (sexp :tag "Type")))) + +(defcustom pgg-parse-compression-algorithm-alist + '((0 . nil); Uncompressed + (1 . ZIP) + (2 . ZLIB)) + "Alist of the assigned number to the compression algorithm." + :group 'pgg-parse + :type '(repeat + (cons (sexp :tag "Number") (sexp :tag "Type")))) + +(defcustom pgg-parse-signature-type-alist + '((0 . "Signature of a binary document") + (1 . "Signature of a canonical text document") + (2 . "Standalone signature") + (16 . "Generic certification of a User ID and Public Key packet") + (17 . "Persona certification of a User ID and Public Key packet") + (18 . "Casual certification of a User ID and Public Key packet") + (19 . "Positive certification of a User ID and Public Key packet") + (24 . "Subkey Binding Signature") + (31 . "Signature directly on a key") + (32 . "Key revocation signature") + (40 . "Subkey revocation signature") + (48 . "Certification revocation signature") + (64 . "Timestamp signature.")) + "Alist of the assigned number to the signature type." + :group 'pgg-parse + :type '(repeat + (cons (sexp :tag "Number") (sexp :tag "Type")))) + +(defcustom pgg-ignore-packet-checksum t; XXX + "If non-nil checksum of each ascii armored packet will be ignored." + :group 'pgg-parse + :type 'boolean) + +(defvar pgg-armor-header-lines + '("^-----BEGIN PGP MESSAGE\\(, PART [0-9]+\\(/[0-9]+\\)?\\)?-----\r?$" + "^-----BEGIN PGP PUBLIC KEY BLOCK-----\r?$" + "^-----BEGIN PGP PRIVATE KEY BLOCK-----\r?$" + "^-----BEGIN PGP SIGNATURE-----\r?$") + "Armor headers.") + +(eval-and-compile + (defalias 'pgg-char-int (if (fboundp 'char-int) + 'char-int + 'identity))) + +(defmacro pgg-format-key-identifier (string) + `(mapconcat (lambda (c) (format "%02X" (pgg-char-int c))) + ,string "") + ;; `(upcase (apply #'format "%02x%02x%02x%02x%02x%02x%02x%02x" + ;; (string-to-number-list ,string))) + ) + +(defmacro pgg-parse-time-field (bytes) + `(list (logior (lsh (car ,bytes) 8) + (nth 1 ,bytes)) + (logior (lsh (nth 2 ,bytes) 8) + (nth 3 ,bytes)) + 0)) + +(defmacro pgg-byte-after (&optional pos) + `(pgg-char-int (char-after ,(or pos `(point))))) + +(defmacro pgg-read-byte () + `(pgg-char-int (char-after (prog1 (point) (forward-char))))) + +(defmacro pgg-read-bytes-string (nbytes) + `(buffer-substring + (point) (prog1 (+ ,nbytes (point)) + (forward-char ,nbytes)))) + +(defmacro pgg-read-bytes (nbytes) + `(mapcar #'pgg-char-int (pgg-read-bytes-string ,nbytes)) + ;; `(string-to-number-list (pgg-read-bytes-string ,nbytes)) + ) + +(defmacro pgg-read-body-string (ptag) + `(if (nth 1 ,ptag) + (pgg-read-bytes-string (nth 1 ,ptag)) + (pgg-read-bytes-string (- (point-max) (point))))) + +(defmacro pgg-read-body (ptag) + `(mapcar #'pgg-char-int (pgg-read-body-string ,ptag)) + ;; `(string-to-number-list (pgg-read-body-string ,ptag)) + ) + +(defalias 'pgg-skip-bytes 'forward-char) + +(defmacro pgg-skip-header (ptag) + `(pgg-skip-bytes (nth 2 ,ptag))) + +(defmacro pgg-skip-body (ptag) + `(pgg-skip-bytes (nth 1 ,ptag))) + +(defmacro pgg-set-alist (alist key value) + `(setq ,alist (nconc ,alist (list (cons ,key ,value))))) + +(when (fboundp 'define-ccl-program) + + (define-ccl-program pgg-parse-crc24 + '(1 + ((loop + (read r0) (r1 ^= r0) (r2 ^= 0) + (r5 = 0) + (loop + (r1 <<= 1) + (r1 += ((r2 >> 15) & 1)) + (r2 <<= 1) + (if (r1 & 256) + ((r1 ^= 390) (r2 ^= 19707))) + (if (r5 < 7) + ((r5 += 1) + (repeat)))) + (repeat))))) + + (defvar pgg-parse-crc24) + + (defun pgg-parse-crc24-string (string) + (let ((h (vector nil 183 1230 nil nil nil nil nil nil))) + (ccl-execute-on-string pgg-parse-crc24 h string) + (format "%c%c%c" + (logand (aref h 1) 255) + (logand (lsh (aref h 2) -8) 255) + (logand (aref h 2) 255))))) + +(defmacro pgg-parse-length-type (c) + `(cond + ((< ,c 192) (cons ,c 1)) + ((< ,c 224) + (cons (+ (lsh (- ,c 192) 8) + (pgg-byte-after (+ 2 (point))) + 192) + 2)) + ((= ,c 255) + (cons (cons (logior (lsh (pgg-byte-after (+ 2 (point))) 8) + (pgg-byte-after (+ 3 (point)))) + (logior (lsh (pgg-byte-after (+ 4 (point))) 8) + (pgg-byte-after (+ 5 (point))))) + 5)) + (t;partial body length + '(0 . 0)))) + +(defun pgg-parse-packet-header () + (let ((ptag (pgg-byte-after)) + length-type content-tag packet-bytes header-bytes) + (if (zerop (logand 64 ptag));Old format + (progn + (setq length-type (logand ptag 3) + length-type (if (= 3 length-type) 0 (lsh 1 length-type)) + content-tag (logand 15 (lsh ptag -2)) + packet-bytes 0 + header-bytes (1+ length-type)) + (dotimes (i length-type) + (setq packet-bytes + (logior (lsh packet-bytes 8) + (pgg-byte-after (+ 1 i (point))))))) + (setq content-tag (logand 63 ptag) + length-type (pgg-parse-length-type + (pgg-byte-after (1+ (point)))) + packet-bytes (car length-type) + header-bytes (1+ (cdr length-type)))) + (list content-tag packet-bytes header-bytes))) + +(defun pgg-parse-packet (ptag) + (case (car ptag) + (1 ;Public-Key Encrypted Session Key Packet + (pgg-parse-public-key-encrypted-session-key-packet ptag)) + (2 ;Signature Packet + (pgg-parse-signature-packet ptag)) + (3 ;Symmetric-Key Encrypted Session Key Packet + (pgg-parse-symmetric-key-encrypted-session-key-packet ptag)) + ;; 4 -- One-Pass Signature Packet + ;; 5 -- Secret Key Packet + (6 ;Public Key Packet + (pgg-parse-public-key-packet ptag)) + ;; 7 -- Secret Subkey Packet + ;; 8 -- Compressed Data Packet + (9 ;Symmetrically Encrypted Data Packet + (pgg-read-body-string ptag)) + (10 ;Marker Packet + (pgg-read-body-string ptag)) + (11 ;Literal Data Packet + (pgg-read-body-string ptag)) + ;; 12 -- Trust Packet + (13 ;User ID Packet + (pgg-read-body-string ptag)) + ;; 14 -- Public Subkey Packet + ;; 60 .. 63 -- Private or Experimental Values + )) + +(defun pgg-parse-packets (&optional header-parser body-parser) + (let ((header-parser + (or header-parser + (function pgg-parse-packet-header))) + (body-parser + (or body-parser + (function pgg-parse-packet))) + result ptag) + (while (> (point-max) (1+ (point))) + (setq ptag (funcall header-parser)) + (pgg-skip-header ptag) + (push (cons (car ptag) + (save-excursion + (funcall body-parser ptag))) + result) + (if (zerop (nth 1 ptag)) + (goto-char (point-max)) + (forward-char (nth 1 ptag)))) + result)) + +(defun pgg-parse-signature-subpacket-header () + (let ((length-type (pgg-parse-length-type (pgg-byte-after)))) + (list (pgg-byte-after (+ (cdr length-type) (point))) + (1- (car length-type)) + (1+ (cdr length-type))))) + +(defun pgg-parse-signature-subpacket (ptag) + (case (car ptag) + (2 ;signature creation time + (cons 'creation-time + (let ((bytes (pgg-read-bytes 4))) + (pgg-parse-time-field bytes)))) + (3 ;signature expiration time + (cons 'signature-expiry + (let ((bytes (pgg-read-bytes 4))) + (pgg-parse-time-field bytes)))) + (4 ;exportable certification + (cons 'exportability (pgg-read-byte))) + (5 ;trust signature + (cons 'trust-level (pgg-read-byte))) + (6 ;regular expression + (cons 'regular-expression + (pgg-read-body-string ptag))) + (7 ;revocable + (cons 'revocability (pgg-read-byte))) + (9 ;key expiration time + (cons 'key-expiry + (let ((bytes (pgg-read-bytes 4))) + (pgg-parse-time-field bytes)))) + ;; 10 = placeholder for backward compatibility + (11 ;preferred symmetric algorithms + (cons 'preferred-symmetric-key-algorithm + (cdr (assq (pgg-read-byte) + pgg-parse-symmetric-key-algorithm-alist)))) + (12 ;revocation key + ) + (16 ;issuer key ID + (cons 'key-identifier + (pgg-format-key-identifier (pgg-read-body-string ptag)))) + (20 ;notation data + (pgg-skip-bytes 4) + (cons 'notation + (let ((name-bytes (pgg-read-bytes 2)) + (value-bytes (pgg-read-bytes 2))) + (cons (pgg-read-bytes-string + (logior (lsh (car name-bytes) 8) + (nth 1 name-bytes))) + (pgg-read-bytes-string + (logior (lsh (car value-bytes) 8) + (nth 1 value-bytes))))))) + (21 ;preferred hash algorithms + (cons 'preferred-hash-algorithm + (cdr (assq (pgg-read-byte) + pgg-parse-hash-algorithm-alist)))) + (22 ;preferred compression algorithms + (cons 'preferred-compression-algorithm + (cdr (assq (pgg-read-byte) + pgg-parse-compression-algorithm-alist)))) + (23 ;key server preferences + (cons 'key-server-preferences + (pgg-read-body ptag))) + (24 ;preferred key server + (cons 'preferred-key-server + (pgg-read-body-string ptag))) + ;; 25 = primary user id + (26 ;policy URL + (cons 'policy-url (pgg-read-body-string ptag))) + ;; 27 = key flags + ;; 28 = signer's user id + ;; 29 = reason for revocation + ;; 100 to 110 = internal or user-defined + )) + +(defun pgg-parse-signature-packet (ptag) + (let* ((signature-version (pgg-byte-after)) + (result (list (cons 'version signature-version))) + hashed-material field n) + (cond + ((= signature-version 3) + (pgg-skip-bytes 2) + (setq hashed-material (pgg-read-bytes 5)) + (pgg-set-alist result + 'signature-type + (cdr (assq (pop hashed-material) + pgg-parse-signature-type-alist))) + (pgg-set-alist result + 'creation-time + (pgg-parse-time-field hashed-material)) + (pgg-set-alist result + 'key-identifier + (pgg-format-key-identifier + (pgg-read-bytes-string 8))) + (pgg-set-alist result + 'public-key-algorithm (pgg-read-byte)) + (pgg-set-alist result + 'hash-algorithm (pgg-read-byte))) + ((= signature-version 4) + (pgg-skip-bytes 1) + (pgg-set-alist result + 'signature-type + (cdr (assq (pgg-read-byte) + pgg-parse-signature-type-alist))) + (pgg-set-alist result + 'public-key-algorithm + (pgg-read-byte)) + (pgg-set-alist result + 'hash-algorithm (pgg-read-byte)) + (when (>= 10000 (setq n (pgg-read-bytes 2) + n (logior (lsh (car n) 8) + (nth 1 n)))) + (save-restriction + (narrow-to-region (point)(+ n (point))) + (nconc result + (mapcar (function cdr) ;remove packet types + (pgg-parse-packets + #'pgg-parse-signature-subpacket-header + #'pgg-parse-signature-subpacket))) + (goto-char (point-max)))) + (when (>= 10000 (setq n (pgg-read-bytes 2) + n (logior (lsh (car n) 8) + (nth 1 n)))) + (save-restriction + (narrow-to-region (point)(+ n (point))) + (nconc result + (mapcar (function cdr) ;remove packet types + (pgg-parse-packets + #'pgg-parse-signature-subpacket-header + #'pgg-parse-signature-subpacket))))))) + + (setcdr (setq field (assq 'public-key-algorithm + result)) + (cdr (assq (cdr field) + pgg-parse-public-key-algorithm-alist))) + (setcdr (setq field (assq 'hash-algorithm + result)) + (cdr (assq (cdr field) + pgg-parse-hash-algorithm-alist))) + result)) + +(defun pgg-parse-public-key-encrypted-session-key-packet (ptag) + (let (result) + (pgg-set-alist result + 'version (pgg-read-byte)) + (pgg-set-alist result + 'key-identifier + (pgg-format-key-identifier + (pgg-read-bytes-string 8))) + (pgg-set-alist result + 'public-key-algorithm + (cdr (assq (pgg-read-byte) + pgg-parse-public-key-algorithm-alist))) + result)) + +(defun pgg-parse-symmetric-key-encrypted-session-key-packet (ptag) + (let (result) + (pgg-set-alist result + 'version + (pgg-read-byte)) + (pgg-set-alist result + 'symmetric-key-algorithm + (cdr (assq (pgg-read-byte) + pgg-parse-symmetric-key-algorithm-alist))) + result)) + +(defun pgg-parse-public-key-packet (ptag) + (let* ((key-version (pgg-read-byte)) + (result (list (cons 'version key-version))) + field) + (cond + ((= 3 key-version) + (pgg-set-alist result + 'creation-time + (let ((bytes (pgg-read-bytes 4))) + (pgg-parse-time-field bytes))) + (pgg-set-alist result + 'key-expiry (pgg-read-bytes 2)) + (pgg-set-alist result + 'public-key-algorithm (pgg-read-byte))) + ((= 4 key-version) + (pgg-set-alist result + 'creation-time + (let ((bytes (pgg-read-bytes 4))) + (pgg-parse-time-field bytes))) + (pgg-set-alist result + 'public-key-algorithm (pgg-read-byte)))) + + (setcdr (setq field (assq 'public-key-algorithm + result)) + (cdr (assq (cdr field) + pgg-parse-public-key-algorithm-alist))) + result)) + +;; p-d-p only calls this if it is defined, but the compiler does not +;; recognize that. +(declare-function pgg-parse-crc24-string "pgg-parse" (string)) + +(defun pgg-decode-packets () + (if (re-search-forward "^=\\([A-Za-z0-9+/]\\{4\\}\\)$" nil t) + (let ((p (match-beginning 0)) + (checksum (match-string 1))) + (delete-region p (point-max)) + (if (ignore-errors (base64-decode-region (point-min) p)) + (or (not (fboundp 'pgg-parse-crc24-string)) + pgg-ignore-packet-checksum + (string-equal (base64-encode-string (pgg-parse-crc24-string + (buffer-string))) + checksum) + (progn + (message "PGP packet checksum does not match") + nil)) + (message "PGP packet contain invalid base64") + nil)) + (message "PGP packet checksum not found") + nil)) + +(defun pgg-decode-armor-region (start end) + (save-restriction + (narrow-to-region start end) + (goto-char (point-min)) + (re-search-forward "^-+BEGIN PGP" nil t) + (delete-region (point-min) + (and (search-forward "\n\n") + (match-end 0))) + (when (pgg-decode-packets) + (goto-char (point-min)) + (pgg-parse-packets)))) + +(defun pgg-parse-armor (string) + (with-temp-buffer + (buffer-disable-undo) + (unless (featurep 'xemacs) + (set-buffer-multibyte nil)) + (insert string) + (pgg-decode-armor-region (point-min)(point)))) + +(eval-and-compile + (defalias 'pgg-string-as-unibyte (if (fboundp 'string-as-unibyte) + 'string-as-unibyte + 'identity))) + +(defun pgg-parse-armor-region (start end) + (pgg-parse-armor (pgg-string-as-unibyte (buffer-substring start end)))) + +(provide 'pgg-parse) + +;;; pgg-parse.el ends here diff -r 7a4b15c4bbed -r 62f897baec0a lisp/obsolete/pgg-pgp.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/obsolete/pgg-pgp.el Tue Dec 21 11:30:36 2010 +0900 @@ -0,0 +1,257 @@ +;;; pgg-pgp.el --- PGP 2.* and 6.* support for PGG. + +;; Copyright (C) 1999, 2000, 2002, 2003, 2004, 2005, 2006, 2007, 2008, +;; 2009, 2010 Free Software Foundation, Inc. + +;; Author: Daiki Ueno +;; Created: 1999/11/02 +;; Keywords: PGP, OpenPGP +;; Package: pgg + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(eval-when-compile + (require 'cl) ; for pgg macros + (require 'pgg)) + +(defgroup pgg-pgp () + "PGP 2.* and 6.* interface." + :group 'pgg) + +(defcustom pgg-pgp-program "pgp" + "PGP 2.* and 6.* executable." + :group 'pgg-pgp + :type 'string) + +(defcustom pgg-pgp-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-pgp + :type 'string) + +(defcustom pgg-pgp-shell-command-switch "-c" + "Switch used to have the shell execute its command line argument." + :group 'pgg-pgp + :type 'string) + +(defcustom pgg-pgp-extra-args nil + "Extra arguments for every PGP invocation." + :group 'pgg-pgp + :type '(choice + (const :tag "None" nil) + (string :tag "Arguments"))) + +(defvar pgg-pgp-user-id nil + "PGP ID of your default identity.") + +(defun pgg-pgp-process-region (start end passphrase program args) + (let* ((errors-file-name (pgg-make-temp-file "pgg-errors")) + (args + (concat args + pgg-pgp-extra-args + " 2>" (shell-quote-argument errors-file-name))) + (shell-file-name pgg-pgp-shell-file-name) + (shell-command-switch pgg-pgp-shell-command-switch) + (process-environment process-environment) + (output-buffer pgg-output-buffer) + (errors-buffer pgg-errors-buffer) + (process-connection-type nil) + process status exit-status) + (with-current-buffer (get-buffer-create output-buffer) + (buffer-disable-undo) + (erase-buffer)) + (when passphrase + (setenv "PGPPASSFD" "0")) + (unwind-protect + (progn + (let ((coding-system-for-read 'binary) + (coding-system-for-write 'binary)) + (setq process + (start-process-shell-command "*PGP*" output-buffer + (concat 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))) + (if (and process (eq 'run (process-status process))) + (interrupt-process process)) + (condition-case nil + (delete-file errors-file-name) + (file-error nil))))) + +(defun pgg-pgp-lookup-key (string &optional type) + "Search keys associated with STRING." + (let ((args (list "+batchmode" "+language=en" "-kv" string))) + (with-current-buffer (get-buffer-create pgg-output-buffer) + (buffer-disable-undo) + (erase-buffer) + (apply #'call-process pgg-pgp-program nil t nil args) + (goto-char (point-min)) + (cond + ((re-search-forward "^pub\\s +[0-9]+/" nil t);PGP 2.* + (buffer-substring (point)(+ 8 (point)))) + ((re-search-forward "^Type" nil t);PGP 6.* + (beginning-of-line 2) + (substring + (nth 2 (split-string + (buffer-substring (point)(progn (end-of-line) (point))))) + 2)))))) + +(defun pgg-pgp-encrypt-region (start end recipients &optional sign passphrase) + "Encrypt the current region between START and END." + (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id)) + (passphrase (or passphrase + (when sign + (pgg-read-passphrase + (format "PGP passphrase for %s: " + pgg-pgp-user-id) + pgg-pgp-user-id)))) + (args + (concat + "+encrypttoself=off +verbose=1 +batchmode +language=us -fate " + (if (or recipients pgg-encrypt-for-me) + (mapconcat 'shell-quote-argument + (append recipients + (if pgg-encrypt-for-me + (list pgg-pgp-user-id))) " ")) + (if sign (concat " -s -u " (shell-quote-argument pgg-pgp-user-id)))))) + (pgg-pgp-process-region start end nil pgg-pgp-program args) + (pgg-process-when-success nil))) + +(defun pgg-pgp-decrypt-region (start end &optional passphrase) + "Decrypt the current region between START and END. + +If optional PASSPHRASE is not specified, it will be obtained from the +passphrase cache or user." + (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id)) + (key (pgg-pgp-lookup-key pgg-pgp-user-id 'encrypt)) + (passphrase + (or passphrase + (pgg-read-passphrase + (format "PGP passphrase for %s: " pgg-pgp-user-id) key))) + (args + "+verbose=1 +batchmode +language=us -f")) + (pgg-pgp-process-region start end passphrase pgg-pgp-program args) + (pgg-process-when-success + (if pgg-cache-passphrase + (pgg-add-passphrase-to-cache key passphrase))))) + +(defun pgg-pgp-sign-region (start end &optional clearsign passphrase) + "Make detached signature from text between START and END. + +If optional PASSPHRASE is not specified, it will be obtained from the +passphrase cache or user." + (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id)) + (passphrase + (or passphrase + (pgg-read-passphrase + (format "PGP passphrase for %s: " pgg-pgp-user-id) + (pgg-pgp-lookup-key pgg-pgp-user-id 'sign)))) + (args + (concat (if clearsign "-fast" "-fbast") + " +verbose=1 +language=us +batchmode" + " -u " (shell-quote-argument pgg-pgp-user-id)))) + (pgg-pgp-process-region start end passphrase pgg-pgp-program args) + (pgg-process-when-success + (goto-char (point-min)) + (when (re-search-forward "^-+BEGIN PGP" 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-to-cache + (cdr (assq 'key-identifier packet)) + passphrase))))))) + +(defun pgg-pgp-verify-region (start end &optional signature) + "Verify region between START and END as the detached signature SIGNATURE." + (let* ((orig-file (pgg-make-temp-file "pgg")) + (args "+verbose=1 +batchmode +language=us") + (orig-mode (default-file-modes))) + (unwind-protect + (progn + (set-default-file-modes 448) + (let ((coding-system-for-write 'binary) + jka-compr-compression-info-list jam-zcat-filename-list) + (write-region start end orig-file))) + (set-default-file-modes orig-mode)) + (if (stringp signature) + (progn + (copy-file signature (setq signature (concat orig-file ".asc"))) + (setq args (concat args " " (shell-quote-argument signature))))) + (setq args (concat args " " (shell-quote-argument orig-file))) + (pgg-pgp-process-region (point)(point) nil pgg-pgp-program args) + (delete-file orig-file) + (if signature (delete-file signature)) + (pgg-process-when-success + (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))))) + (goto-char (point-min)) + (when (re-search-forward "^\\.$" nil t) + (delete-region (point-min) + (progn (beginning-of-line 2) + (point))))))) + +(defun pgg-pgp-insert-key () + "Insert public key at point." + (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id)) + (args + (concat "+verbose=1 +batchmode +language=us -kxaf " + (shell-quote-argument pgg-pgp-user-id)))) + (pgg-pgp-process-region (point)(point) nil pgg-pgp-program args) + (insert-buffer-substring pgg-output-buffer))) + +(defun pgg-pgp-snarf-keys-region (start end) + "Add all public keys in region between START and END to the keyring." + (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id)) + (key-file (pgg-make-temp-file "pgg")) + (args + (concat "+verbose=1 +batchmode +language=us -kaf " + (shell-quote-argument key-file)))) + (let ((coding-system-for-write 'raw-text-dos)) + (write-region start end key-file)) + (pgg-pgp-process-region start end nil pgg-pgp-program args) + (delete-file key-file) + (pgg-process-when-success nil))) + +(provide 'pgg-pgp) + +;;; pgg-pgp.el ends here diff -r 7a4b15c4bbed -r 62f897baec0a lisp/obsolete/pgg-pgp5.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/obsolete/pgg-pgp5.el Tue Dec 21 11:30:36 2010 +0900 @@ -0,0 +1,258 @@ +;;; pgg-pgp5.el --- PGP 5.* support for PGG. + +;; Copyright (C) 1999, 2000, 2002, 2003, 2004, +;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. + +;; Author: Daiki Ueno +;; Created: 1999/11/02 +;; Keywords: PGP, OpenPGP +;; Package: pgg + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(eval-when-compile + (require 'cl) ; for pgg macros + (require 'pgg)) + +(defgroup pgg-pgp5 () + "PGP 5.* interface." + :group 'pgg) + +(defcustom pgg-pgp5-pgpe-program "pgpe" + "PGP 5.* 'pgpe' executable." + :group 'pgg-pgp5 + :type 'string) + +(defcustom pgg-pgp5-pgps-program "pgps" + "PGP 5.* 'pgps' executable." + :group 'pgg-pgp5 + :type 'string) + +(defcustom pgg-pgp5-pgpk-program "pgpk" + "PGP 5.* 'pgpk' executable." + :group 'pgg-pgp5 + :type 'string) + +(defcustom pgg-pgp5-pgpv-program "pgpv" + "PGP 5.* 'pgpv' executable." + :group 'pgg-pgp5 + :type 'string) + +(defcustom pgg-pgp5-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-pgp5 + :type 'string) + +(defcustom pgg-pgp5-shell-command-switch "-c" + "Switch used to have the shell execute its command line argument." + :group 'pgg-pgp5 + :type 'string) + +(defcustom pgg-pgp5-extra-args nil + "Extra arguments for every PGP 5.* invocation." + :group 'pgg-pgp5 + :type '(choice + (const :tag "None" nil) + (string :tag "Arguments"))) + +(defvar pgg-pgp5-user-id nil + "PGP 5.* ID of your default identity.") + +(defun pgg-pgp5-process-region (start end passphrase program args) + (let* ((errors-file-name (pgg-make-temp-file "pgg-errors")) + (args + (append args + pgg-pgp5-extra-args + (list (concat "2>" errors-file-name)))) + (shell-file-name pgg-pgp5-shell-file-name) + (shell-command-switch pgg-pgp5-shell-command-switch) + (process-environment process-environment) + (output-buffer pgg-output-buffer) + (errors-buffer pgg-errors-buffer) + (process-connection-type nil) + process status exit-status) + (with-current-buffer (get-buffer-create output-buffer) + (buffer-disable-undo) + (erase-buffer)) + (when passphrase + (setenv "PGPPASSFD" "0")) + (unwind-protect + (progn + (let ((coding-system-for-read 'binary) + (coding-system-for-write 'binary)) + (setq process + (apply #'funcall + #'start-process-shell-command "*PGP*" 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))) + (if (and process (eq 'run (process-status process))) + (interrupt-process process)) + (condition-case nil + (delete-file errors-file-name) + (file-error nil))))) + +(defun pgg-pgp5-lookup-key (string &optional type) + "Search keys associated with STRING." + (let ((args (list "+language=en" "-l" string))) + (with-current-buffer (get-buffer-create pgg-output-buffer) + (buffer-disable-undo) + (erase-buffer) + (apply #'call-process pgg-pgp5-pgpk-program nil t nil args) + (goto-char (point-min)) + (when (re-search-forward "^sec" nil t) + (substring + (nth 2 (split-string + (buffer-substring (match-end 0)(progn (end-of-line)(point))))) + 2))))) + +(defun pgg-pgp5-encrypt-region (start end recipients &optional sign passphrase) + "Encrypt the current region between START and END." + (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) + (passphrase (or passphrase + (when sign + (pgg-read-passphrase + (format "PGP passphrase for %s: " + pgg-pgp5-user-id) + pgg-pgp5-user-id)))) + (args + (append + `("+NoBatchInvalidKeys=off" "-fat" "+batchmode=1" + ,@(if (or recipients pgg-encrypt-for-me) + (apply #'append + (mapcar (lambda (rcpt) + (list "-r" + (concat "\"" rcpt "\""))) + (append recipients + (if pgg-encrypt-for-me + (list pgg-pgp5-user-id))))))) + (if sign '("-s" "-u" pgg-pgp5-user-id))))) + (pgg-pgp5-process-region start end nil pgg-pgp5-pgpe-program args) + (pgg-process-when-success nil))) + +(defun pgg-pgp5-decrypt-region (start end &optional passphrase) + "Decrypt the current region between START and END." + (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) + (passphrase + (or passphrase + (pgg-read-passphrase + (format "PGP passphrase for %s: " pgg-pgp5-user-id) + (pgg-pgp5-lookup-key pgg-pgp5-user-id 'encrypt)))) + (args + '("+verbose=1" "+batchmode=1" "+language=us" "-f"))) + (pgg-pgp5-process-region start end passphrase pgg-pgp5-pgpv-program args) + (pgg-process-when-success nil))) + +(defun pgg-pgp5-sign-region (start end &optional clearsign passphrase) + "Make detached signature from text between START and END." + (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) + (passphrase + (or passphrase + (pgg-read-passphrase + (format "PGP passphrase for %s: " pgg-pgp5-user-id) + (pgg-pgp5-lookup-key pgg-pgp5-user-id 'sign)))) + (args + (list (if clearsign "-fat" "-fbat") + "+verbose=1" "+language=us" "+batchmode=1" + "-u" pgg-pgp5-user-id))) + (pgg-pgp5-process-region start end passphrase pgg-pgp5-pgps-program args) + (pgg-process-when-success + (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-to-cache + (cdr (assq 'key-identifier packet)) + passphrase))))))) + +(defun pgg-pgp5-verify-region (start end &optional signature) + "Verify region between START and END as the detached signature SIGNATURE." + (let ((orig-file (pgg-make-temp-file "pgg")) + (args '("+verbose=1" "+batchmode=1" "+language=us")) + (orig-mode (default-file-modes))) + (unwind-protect + (progn + (set-default-file-modes 448) + (let ((coding-system-for-write 'binary) + jka-compr-compression-info-list jam-zcat-filename-list) + (write-region start end orig-file))) + (set-default-file-modes orig-mode)) + (when (stringp signature) + (copy-file signature (setq signature (concat orig-file ".asc"))) + (setq args (append args (list signature)))) + (pgg-pgp5-process-region (point)(point) nil pgg-pgp5-pgpv-program args) + (delete-file orig-file) + (if signature (delete-file signature)) + (with-current-buffer pgg-errors-buffer + (goto-char (point-min)) + (if (re-search-forward "^Good signature" nil t) + (progn + (set-buffer pgg-output-buffer) + (insert-buffer-substring pgg-errors-buffer) + t) + nil)))) + +(defun pgg-pgp5-insert-key () + "Insert public key at point." + (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) + (args + (list "+verbose=1" "+batchmode=1" "+language=us" "-x" + (concat "\"" pgg-pgp5-user-id "\"")))) + (pgg-pgp5-process-region (point)(point) nil pgg-pgp5-pgpk-program args) + (insert-buffer-substring pgg-output-buffer))) + +(defun pgg-pgp5-snarf-keys-region (start end) + "Add all public keys in region between START and END to the keyring." + (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) + (key-file (pgg-make-temp-file "pgg")) + (args + (list "+verbose=1" "+batchmode=1" "+language=us" "-a" + key-file))) + (let ((coding-system-for-write 'raw-text-dos)) + (write-region start end key-file)) + (pgg-pgp5-process-region start end nil pgg-pgp5-pgpk-program args) + (delete-file key-file) + (pgg-process-when-success nil))) + +(provide 'pgg-pgp5) + +;;; pgg-pgp5.el ends here diff -r 7a4b15c4bbed -r 62f897baec0a lisp/obsolete/pgg.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/obsolete/pgg.el Tue Dec 21 11:30:36 2010 +0900 @@ -0,0 +1,599 @@ +;;; pgg.el --- glue for the various PGP implementations. + +;; Copyright (C) 1999, 2000, 2002, 2003, 2004, +;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. + +;; Author: Daiki Ueno +;; Symmetric encryption added by: Sascha Wilde +;; Created: 1999/10/28 +;; Keywords: PGP + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(require 'pgg-def) +(require 'pgg-parse) +(autoload 'run-at-time "timer") + +;; Don't merge these two `eval-when-compile's. +(eval-when-compile + ;; For Emacs <22.2 and XEmacs. + (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))) + (require 'cl)) + +;;; @ utility functions +;;; + +(eval-when-compile + (when (featurep 'xemacs) + (defmacro pgg-run-at-time-1 (time repeat function args) + (if (condition-case nil + (let ((delete-itimer 'delete-itimer) + (itimer-driver-start 'itimer-driver-start) + (itimer-value 'itimer-value) + (start-itimer 'start-itimer)) + (unless (or (symbol-value 'itimer-process) + (symbol-value 'itimer-timer)) + (funcall itimer-driver-start)) + ;; Check whether there is a bug to which the difference of + ;; the present time and the time when the itimer driver was + ;; woken up is subtracted from the initial itimer value. + (let* ((inhibit-quit t) + (ctime (current-time)) + (itimer-timer-last-wakeup + (prog1 + ctime + (setcar ctime (1- (car ctime))))) + (itimer-list nil) + (itimer (funcall start-itimer "pgg-run-at-time" + 'ignore 5))) + (sleep-for 0.1) ;; Accept the timeout interrupt. + (prog1 + (> (funcall itimer-value itimer) 0) + (funcall delete-itimer itimer)))) + (error nil)) + `(let ((time ,time)) + (apply #'start-itimer "pgg-run-at-time" + ,function (if time (max time 1e-9) 1e-9) + ,repeat nil t ,args)) + `(let ((time ,time) + (itimers (list nil))) + (setcar + itimers + (apply #'start-itimer "pgg-run-at-time" + (lambda (itimers repeat function &rest args) + (let ((itimer (car itimers))) + (if repeat + (progn + (set-itimer-function + itimer + (lambda (itimer repeat function &rest args) + (set-itimer-restart itimer repeat) + (set-itimer-function itimer function) + (set-itimer-function-arguments itimer args) + (apply function args))) + (set-itimer-function-arguments + itimer + (append (list itimer repeat function) args))) + (set-itimer-function + itimer + (lambda (itimer function &rest args) + (delete-itimer itimer) + (apply function args))) + (set-itimer-function-arguments + itimer + (append (list itimer function) args))))) + 1e-9 (if time (max time 1e-9) 1e-9) + nil t itimers ,repeat ,function ,args))))))) + +(eval-and-compile + (if (featurep 'xemacs) + (progn + (defun pgg-run-at-time (time repeat function &rest args) + "Emulating function run as `run-at-time'. +TIME should be nil meaning now, or a number of seconds from now. +Return an itimer object which can be used in either `delete-itimer' +or `cancel-timer'." + (pgg-run-at-time-1 time repeat function args)) + (defun pgg-cancel-timer (timer) + "Emulate cancel-timer for xemacs." + (let ((delete-itimer 'delete-itimer)) + (funcall delete-itimer timer)))) + (defalias 'pgg-run-at-time 'run-at-time) + (defalias 'pgg-cancel-timer 'cancel-timer))) + +(defun pgg-invoke (func scheme &rest args) + (progn + (require (intern (format "pgg-%s" scheme))) + (apply 'funcall (intern (format "pgg-%s-%s" scheme func)) args))) + +(put 'pgg-save-coding-system 'lisp-indent-function 2) + +(defmacro pgg-save-coding-system (start end &rest body) + `(if (called-interactively-p 'interactive) + (let ((buffer (current-buffer))) + (with-temp-buffer + (let (buffer-undo-list) + (insert-buffer-substring buffer ,start ,end) + (encode-coding-region (point-min)(point-max) + buffer-file-coding-system) + (prog1 (save-excursion ,@body) + (push nil buffer-undo-list) + (ignore-errors (undo)))))) + (save-restriction + (narrow-to-region ,start ,end) + ,@body))) + +(defun pgg-temp-buffer-show-function (buffer) + (let ((window (or (get-buffer-window buffer 'visible) + (split-window-vertically)))) + (set-window-buffer window buffer) + (shrink-window-if-larger-than-buffer window))) + +;; XXX `pgg-display-output-buffer' is a horrible name for this function. +;; It should be something like `pgg-situate-output-or-display-error'. +(defun pgg-display-output-buffer (start end status) + "Situate en/decryption results or pop up an error buffer. + +Text from START to END is replaced by contents of output buffer if STATUS +is true, or else the output buffer is displayed." + (if status + (pgg-situate-output start end) + (pgg-display-error-buffer))) + +(defun pgg-situate-output (start end) + "Place en/decryption result in place of current text from START to END." + (delete-region start end) + (insert-buffer-substring pgg-output-buffer) + (decode-coding-region start (point) buffer-file-coding-system)) + +(defun pgg-display-error-buffer () + "Pop up an error buffer indicating the reason for an en/decryption failure." + (let ((temp-buffer-show-function + (function pgg-temp-buffer-show-function))) + (with-output-to-temp-buffer pgg-echo-buffer + (set-buffer standard-output) + (insert-buffer-substring pgg-errors-buffer)))) + +(defvar pgg-passphrase-cache (make-vector 7 0)) + +(defvar pgg-pending-timers (make-vector 7 0) + "Hash table for managing scheduled pgg cache management timers. + +We associate key and timer, so the timer can be cancelled if a new +timeout for the key is set while an old one is still pending.") + +(defun pgg-read-passphrase (prompt &optional key notruncate) + "Using PROMPT, obtain passphrase for KEY from cache or user. + +Truncate the key to 8 trailing characters unless NOTRUNCATE is true +\(default false). + +Custom variables `pgg-cache-passphrase' and `pgg-passphrase-cache-expiry' +regulate cache behavior." + (or (pgg-read-passphrase-from-cache key notruncate) + (read-passwd prompt))) + +(defun pgg-read-passphrase-from-cache (key &optional notruncate) + "Obtain passphrase for KEY from time-limited passphrase cache. + +Truncate the key to 8 trailing characters unless NOTRUNCATE is true +\(default false). + +Custom variables `pgg-cache-passphrase' and `pgg-passphrase-cache-expiry' +regulate cache behavior." + (and pgg-cache-passphrase + key (or notruncate + (setq key (pgg-truncate-key-identifier key))) + (symbol-value (intern-soft key pgg-passphrase-cache)))) + +(defun pgg-add-passphrase-to-cache (key passphrase &optional notruncate) + "Associate KEY with PASSPHRASE in time-limited passphrase cache. + +Truncate the key to 8 trailing characters unless NOTRUNCATE is true +\(default false). + +Custom variables `pgg-cache-passphrase' and `pgg-passphrase-cache-expiry' +regulate cache behavior." + + (let* ((key (if notruncate key (pgg-truncate-key-identifier key))) + (interned-timer-key (intern-soft key pgg-pending-timers)) + (old-timer (symbol-value interned-timer-key)) + new-timer) + (when old-timer + (cancel-timer old-timer) + (unintern interned-timer-key pgg-pending-timers)) + (set (intern key pgg-passphrase-cache) + passphrase) + (set (intern key pgg-pending-timers) + (pgg-run-at-time pgg-passphrase-cache-expiry nil + #'pgg-remove-passphrase-from-cache + key notruncate)))) + +(if (fboundp 'clear-string) + (defalias 'pgg-clear-string 'clear-string) + (defun pgg-clear-string (string) + (fillarray string ?_))) + +(declare-function pgg-clear-string "pgg" (string)) + +(defun pgg-remove-passphrase-from-cache (key &optional notruncate) + "Omit passphrase associated with KEY in time-limited passphrase cache. + +Truncate the key to 8 trailing characters unless NOTRUNCATE is true +\(default false). + +This is a no-op if there is not entry for KEY (eg, it's already expired. + +The memory for the passphrase is filled with underscores to clear any +references to it. + +Custom variables `pgg-cache-passphrase' and `pgg-passphrase-cache-expiry' +regulate cache behavior." + (let* ((passphrase (pgg-read-passphrase-from-cache key notruncate)) + (key (if notruncate key (pgg-truncate-key-identifier key))) + (interned-timer-key (intern-soft key pgg-pending-timers)) + (old-timer (symbol-value interned-timer-key))) + (when passphrase + (pgg-clear-string passphrase) + (unintern key pgg-passphrase-cache)) + (when old-timer + (pgg-cancel-timer old-timer) + (unintern interned-timer-key pgg-pending-timers)))) + +(defmacro pgg-convert-lbt-region (start end lbt) + `(let ((pgg-conversion-end (set-marker (make-marker) ,end))) + (goto-char ,start) + (case ,lbt + (CRLF + (while (progn + (end-of-line) + (> (marker-position pgg-conversion-end) (point))) + (insert "\r") + (forward-line 1))) + (LF + (while (re-search-forward "\r$" pgg-conversion-end t) + (replace-match "")))))) + +(put 'pgg-as-lbt 'lisp-indent-function 3) + +(defmacro pgg-as-lbt (start end lbt &rest body) + `(let ((inhibit-read-only t) + buffer-read-only + buffer-undo-list) + (pgg-convert-lbt-region ,start ,end ,lbt) + (let ((,end (point))) + ,@body) + (push nil buffer-undo-list) + (ignore-errors (undo)))) + +(put 'pgg-process-when-success 'lisp-indent-function 0) + +(defmacro pgg-process-when-success (&rest body) + `(with-current-buffer pgg-output-buffer + (if (zerop (buffer-size)) nil ,@body t))) + +(defalias 'pgg-make-temp-file + (if (fboundp 'make-temp-file) + 'make-temp-file + (lambda (prefix &optional dir-flag) + (let ((file (expand-file-name + (make-temp-name prefix) + (if (fboundp 'temp-directory) + (temp-directory) + temporary-file-directory)))) + (if dir-flag + (make-directory file)) + file)))) + +;;; @ interface functions +;;; + +;;;###autoload +(defun pgg-encrypt-region (start end rcpts &optional sign passphrase) + "Encrypt the current region between START and END for RCPTS. + +If optional argument SIGN is non-nil, do a combined sign and encrypt. + +If optional PASSPHRASE is not specified, it will be obtained from the +passphrase cache or user." + (interactive + (list (region-beginning)(region-end) + (split-string (read-string "Recipients: ") "[ \t,]+"))) + (let ((status + (pgg-save-coding-system start end + (pgg-invoke "encrypt-region" (or pgg-scheme pgg-default-scheme) + (point-min) (point-max) rcpts sign passphrase)))) + (when (called-interactively-p 'interactive) + (pgg-display-output-buffer start end status)) + status)) + +;;;###autoload +(defun pgg-encrypt-symmetric-region (start end &optional passphrase) + "Encrypt the current region between START and END symmetric with passphrase. + +If optional PASSPHRASE is not specified, it will be obtained from the +cache or user." + (interactive "r") + (let ((status + (pgg-save-coding-system start end + (pgg-invoke "encrypt-symmetric-region" + (or pgg-scheme pgg-default-scheme) + (point-min) (point-max) passphrase)))) + (when (called-interactively-p 'interactive) + (pgg-display-output-buffer start end status)) + status)) + +;;;###autoload +(defun pgg-encrypt-symmetric (&optional start end passphrase) + "Encrypt the current buffer using a symmetric, rather than key-pair, cipher. + +If optional arguments START and END are specified, only encrypt within +the region. + +If optional PASSPHRASE is not specified, it will be obtained from the +passphrase cache or user." + (interactive) + (let* ((start (or start (point-min))) + (end (or end (point-max))) + (status (pgg-encrypt-symmetric-region start end passphrase))) + (when (called-interactively-p 'interactive) + (pgg-display-output-buffer start end status)) + status)) + +;;;###autoload +(defun pgg-encrypt (rcpts &optional sign start end passphrase) + "Encrypt the current buffer for RCPTS. + +If optional argument SIGN is non-nil, do a combined sign and encrypt. + +If optional arguments START and END are specified, only encrypt within +the region. + +If optional PASSPHRASE is not specified, it will be obtained from the +passphrase cache or user." + (interactive (list (split-string (read-string "Recipients: ") "[ \t,]+"))) + (let* ((start (or start (point-min))) + (end (or end (point-max))) + (status (pgg-encrypt-region start end rcpts sign passphrase))) + (when (called-interactively-p 'interactive) + (pgg-display-output-buffer start end status)) + status)) + +;;;###autoload +(defun pgg-decrypt-region (start end &optional passphrase) + "Decrypt the current region between START and END. + +If optional PASSPHRASE is not specified, it will be obtained from the +passphrase cache or user." + (interactive "r") + (let* ((buf (current-buffer)) + (status + (pgg-save-coding-system start end + (pgg-invoke "decrypt-region" (or pgg-scheme pgg-default-scheme) + (point-min) (point-max) passphrase)))) + (when (called-interactively-p 'interactive) + (pgg-display-output-buffer start end status)) + status)) + +;;;###autoload +(defun pgg-decrypt (&optional start end passphrase) + "Decrypt the current buffer. + +If optional arguments START and END are specified, only decrypt within +the region. + +If optional PASSPHRASE is not specified, it will be obtained from the +passphrase cache or user." + (interactive "") + (let* ((start (or start (point-min))) + (end (or end (point-max))) + (status (pgg-decrypt-region start end passphrase))) + (when (called-interactively-p 'interactive) + (pgg-display-output-buffer start end status)) + status)) + +;;;###autoload +(defun pgg-sign-region (start end &optional cleartext passphrase) + "Make the signature from text between START and END. + +If the optional 3rd argument CLEARTEXT is non-nil, it does not create +a detached signature. + +If this function is called interactively, CLEARTEXT is enabled +and the output is displayed. + +If optional PASSPHRASE is not specified, it will be obtained from the +passphrase cache or user." + (interactive "r") + (let ((status (pgg-save-coding-system start end + (pgg-invoke "sign-region" (or pgg-scheme pgg-default-scheme) + (point-min) (point-max) + (or (called-interactively-p 'interactive) + cleartext) + passphrase)))) + (when (called-interactively-p 'interactive) + (pgg-display-output-buffer start end status)) + status)) + +;;;###autoload +(defun pgg-sign (&optional cleartext start end passphrase) + "Sign the current buffer. + +If the optional argument CLEARTEXT is non-nil, it does not create a +detached signature. + +If optional arguments START and END are specified, only sign data +within the region. + +If this function is called interactively, CLEARTEXT is enabled +and the output is displayed. + +If optional PASSPHRASE is not specified, it will be obtained from the +passphrase cache or user." + (interactive "") + (let* ((start (or start (point-min))) + (end (or end (point-max))) + (status (pgg-sign-region start end + (or (called-interactively-p 'interactive) + cleartext) + passphrase))) + (when (called-interactively-p 'interactive) + (pgg-display-output-buffer start end status)) + status)) + +;;;###autoload +(defun pgg-verify-region (start end &optional signature fetch) + "Verify the current region between START and END. +If the optional 3rd argument SIGNATURE is non-nil, it is treated as +the detached signature of the current region. + +If the optional 4th argument FETCH is non-nil, we attempt to fetch the +signer's public key from `pgg-default-keyserver-address'." + (interactive "r") + (let* ((packet + (if (null signature) nil + (with-temp-buffer + (buffer-disable-undo) + (unless (featurep 'xemacs) + (set-buffer-multibyte nil)) + (insert-file-contents signature) + (cdr (assq 2 (pgg-decode-armor-region + (point-min)(point-max))))))) + (key (cdr (assq 'key-identifier packet))) + status keyserver) + (and (stringp key) + pgg-query-keyserver + (setq key (concat "0x" (pgg-truncate-key-identifier key))) + (null (pgg-lookup-key key)) + (or fetch (called-interactively-p 'interactive)) + (y-or-n-p (format "Key %s not found; attempt to fetch? " key)) + (setq keyserver + (or (cdr (assq 'preferred-key-server packet)) + pgg-default-keyserver-address)) + (pgg-fetch-key keyserver key)) + (setq status + (pgg-save-coding-system start end + (pgg-invoke "verify-region" (or pgg-scheme pgg-default-scheme) + (point-min) (point-max) signature))) + (when (called-interactively-p 'interactive) + (let ((temp-buffer-show-function + (function pgg-temp-buffer-show-function))) + (with-output-to-temp-buffer pgg-echo-buffer + (set-buffer standard-output) + (insert-buffer-substring (if status pgg-output-buffer + pgg-errors-buffer))))) + status)) + +;;;###autoload +(defun pgg-verify (&optional signature fetch start end) + "Verify the current buffer. +If the optional argument SIGNATURE is non-nil, it is treated as +the detached signature of the current region. +If the optional argument FETCH is non-nil, we attempt to fetch the +signer's public key from `pgg-default-keyserver-address'. +If optional arguments START and END are specified, only verify data +within the region." + (interactive "") + (let* ((start (or start (point-min))) + (end (or end (point-max))) + (status (pgg-verify-region start end signature fetch))) + (when (called-interactively-p 'interactive) + (let ((temp-buffer-show-function + (function pgg-temp-buffer-show-function))) + (with-output-to-temp-buffer pgg-echo-buffer + (set-buffer standard-output) + (insert-buffer-substring (if status pgg-output-buffer + pgg-errors-buffer))))) + status)) + +;;;###autoload +(defun pgg-insert-key () + "Insert the ASCII armored public key." + (interactive) + (pgg-invoke "insert-key" (or pgg-scheme pgg-default-scheme))) + +;;;###autoload +(defun pgg-snarf-keys-region (start end) + "Import public keys in the current region between START and END." + (interactive "r") + (pgg-save-coding-system start end + (pgg-invoke "snarf-keys-region" (or pgg-scheme pgg-default-scheme) + start end))) + +;;;###autoload +(defun pgg-snarf-keys () + "Import public keys in the current buffer." + (interactive "") + (pgg-snarf-keys-region (point-min) (point-max))) + +(defun pgg-lookup-key (string &optional type) + (pgg-invoke "lookup-key" (or pgg-scheme pgg-default-scheme) string type)) + +(defvar pgg-insert-url-function (function pgg-insert-url-with-w3)) + +(defun pgg-insert-url-with-w3 (url) + (ignore-errors + (require 'url) + (let (buffer-file-name) + (url-insert-file-contents url)))) + +(defvar pgg-insert-url-extra-arguments nil) +(defvar pgg-insert-url-program nil) + +(defun pgg-insert-url-with-program (url) + (let ((args (copy-sequence pgg-insert-url-extra-arguments)) + process) + (insert + (with-temp-buffer + (setq process + (apply #'start-process " *PGG url*" (current-buffer) + pgg-insert-url-program (nconc args (list url)))) + (set-process-sentinel process #'ignore) + (while (eq 'run (process-status process)) + (accept-process-output process 5)) + (delete-process process) + (if (and process (eq 'run (process-status process))) + (interrupt-process process)) + (buffer-string))))) + +(defun pgg-fetch-key (keyserver key) + "Attempt to fetch a KEY from KEYSERVER for addition to PGP or GnuPG keyring." + (with-current-buffer (get-buffer-create pgg-output-buffer) + (buffer-disable-undo) + (erase-buffer) + (let ((proto (if (string-match "^[a-zA-Z\\+\\.\\\\-]+:" keyserver) + (substring keyserver 0 (1- (match-end 0)))))) + (save-excursion + (funcall pgg-insert-url-function + (if proto keyserver + (format "http://%s:11371/pks/lookup?op=get&search=%s" + keyserver key)))) + (when (re-search-forward "^-+BEGIN" nil 'last) + (delete-region (point-min) (match-beginning 0)) + (when (re-search-forward "^-+END" nil t) + (delete-region (progn (end-of-line) (point)) + (point-max))) + (insert "\n") + (with-temp-buffer + (insert-buffer-substring pgg-output-buffer) + (pgg-snarf-keys-region (point-min)(point-max))))))) + + +(provide 'pgg) + +;;; pgg.el ends here diff -r 7a4b15c4bbed -r 62f897baec0a lisp/pgg-def.el --- a/lisp/pgg-def.el Mon Dec 20 22:12:30 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,98 +0,0 @@ -;;; pgg-def.el --- functions/macros for defining PGG functions - -;; Copyright (C) 1999, 2002, 2003, 2004, 2005, -;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. - -;; Author: Daiki Ueno -;; Created: 1999/11/02 -;; Keywords: PGP, OpenPGP, GnuPG -;; Package: pgg - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see . - -;;; Code: - -(defgroup pgg () - "Glue for the various PGP implementations." - :group 'mime - :version "22.1") - -(defcustom pgg-default-scheme 'gpg - "Default PGP scheme." - :group 'pgg - :type '(choice (const :tag "GnuPG" gpg) - (const :tag "PGP 5" pgp5) - (const :tag "PGP" pgp))) - -(defcustom pgg-default-user-id (user-login-name) - "User ID of your default identity." - :group 'pgg - :type 'string) - -(defcustom pgg-default-keyserver-address "subkeys.pgp.net" - "Host name of keyserver." - :group 'pgg - :type 'string) - -(defcustom pgg-query-keyserver nil - "Whether PGG queries keyservers for missing keys when verifying messages." - :version "22.1" - :group 'pgg - :type 'boolean) - -(defcustom pgg-encrypt-for-me t - "If t, encrypt all outgoing messages with user's public key." - :group 'pgg - :type 'boolean) - -(defcustom pgg-cache-passphrase t - "If t, cache passphrase." - :group 'pgg - :type 'boolean) - -(defcustom pgg-passphrase-cache-expiry 16 - "How many seconds the passphrase is cached. -Whether the passphrase is cached at all is controlled by -`pgg-cache-passphrase'." - :group 'pgg - :type 'integer) - -(defcustom pgg-passphrase-coding-system nil - "Coding system to encode passphrase." - :group 'pgg - :type 'coding-system) - -(defvar pgg-messages-coding-system nil - "Coding system used when reading from a PGP external process.") - -(defvar pgg-status-buffer " *PGG status*") -(defvar pgg-errors-buffer " *PGG errors*") -(defvar pgg-output-buffer " *PGG output*") - -(defvar pgg-echo-buffer "*PGG-echo*") - -(defvar pgg-scheme nil - "Current scheme of PGP implementation.") - -(defvar pgg-text-mode nil - "If t, inform the recipient that the input is text.") - -(defmacro pgg-truncate-key-identifier (key) - `(if (> (length ,key) 8) (substring ,key -8) ,key)) - -(provide 'pgg-def) - -;;; pgg-def.el ends here diff -r 7a4b15c4bbed -r 62f897baec0a lisp/pgg-gpg.el --- a/lisp/pgg-gpg.el Mon Dec 20 22:12:30 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,410 +0,0 @@ -;;; pgg-gpg.el --- GnuPG support for PGG. - -;; Copyright (C) 1999, 2000, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. - -;; Author: Daiki Ueno -;; Symmetric encryption and gpg-agent support added by: -;; Sascha Wilde -;; Created: 1999/10/28 -;; Keywords: PGP, OpenPGP, GnuPG -;; Package: pgg - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see . - -;;; Code: - -(eval-when-compile - (require 'cl) ; for gpg macros - (require 'pgg)) - -(defgroup pgg-gpg () - "GnuPG interface." - :group 'pgg) - -(defcustom pgg-gpg-program "gpg" - "The GnuPG executable." - :group 'pgg-gpg - :type 'string) - -(defcustom pgg-gpg-extra-args nil - "Extra arguments for every GnuPG invocation." - :group 'pgg-gpg - :type '(repeat (string :tag "Argument"))) - -(defcustom pgg-gpg-recipient-argument "--recipient" - "GnuPG option to specify recipient." - :group 'pgg-gpg - :type '(choice (const :tag "New `--recipient' option" "--recipient") - (const :tag "Old `--remote-user' option" "--remote-user"))) - -(defcustom pgg-gpg-use-agent t - "Whether to use gnupg agent for key caching." - :group 'pgg-gpg - :type 'boolean) - -(defvar pgg-gpg-user-id nil - "GnuPG ID of your default identity.") - -(defun pgg-gpg-process-region (start end passphrase program args) - (let* ((use-agent (and (null passphrase) (pgg-gpg-use-agent-p))) - (output-file-name (pgg-make-temp-file "pgg-output")) - (args - `("--status-fd" "2" - ,@(if use-agent '("--use-agent") - (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) - (orig-mode (default-file-modes)) - (process-connection-type nil) - (inhibit-redisplay t) - process status exit-status - passphrase-with-newline - encoded-passphrase-with-new-line) - (with-current-buffer (get-buffer-create errors-buffer) - (buffer-disable-undo) - (erase-buffer)) - (unwind-protect - (progn - (set-default-file-modes 448) - (let ((coding-system-for-write 'binary)) - (setq process - (apply #'start-process "*GnuPG*" errors-buffer - program args))) - (set-process-sentinel process #'ignore) - (when passphrase - (setq passphrase-with-newline (concat passphrase "\n")) - (if pgg-passphrase-coding-system - (progn - (setq encoded-passphrase-with-new-line - (encode-coding-string - passphrase-with-newline - (coding-system-change-eol-conversion - pgg-passphrase-coding-system 'unix))) - (pgg-clear-string passphrase-with-newline)) - (setq encoded-passphrase-with-new-line passphrase-with-newline - passphrase-with-newline nil)) - (process-send-string process encoded-passphrase-with-new-line)) - (process-send-region process start end) - (process-send-eof process) - (while (eq 'run (process-status process)) - (accept-process-output process 5)) - ;; Accept any remaining pending output coming after the - ;; status change. - (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 (if pgg-text-mode - 'raw-text - 'binary))) - (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 passphrase-with-newline - (pgg-clear-string passphrase-with-newline)) - (if encoded-passphrase-with-new-line - (pgg-clear-string encoded-passphrase-with-new-line)) - (if (and process (eq 'run (process-status process))) - (interrupt-process process)) - (if (file-exists-p output-file-name) - (delete-file output-file-name)) - (set-default-file-modes orig-mode)))) - -(defun pgg-gpg-possibly-cache-passphrase (passphrase &optional key notruncate) - (if (and passphrase - pgg-cache-passphrase - (progn - (goto-char (point-min)) - (re-search-forward "^\\[GNUPG:] \\(GOOD_PASSPHRASE\\>\\)\\|\\(SIG_CREATED\\)" nil t))) - (pgg-add-passphrase-to-cache - (or key - (progn - (goto-char (point-min)) - (if (re-search-forward - "^\\[GNUPG:] NEED_PASSPHRASE\\(_PIN\\)? \\w+ ?\\w*" nil t) - (substring (match-string 0) -8)))) - passphrase - notruncate))) - -(defvar pgg-gpg-all-secret-keys 'unknown) - -(defun pgg-gpg-lookup-all-secret-keys () - "Return all secret keys present in secret key ring." - (when (eq pgg-gpg-all-secret-keys 'unknown) - (setq pgg-gpg-all-secret-keys '()) - (let ((args (list "--with-colons" "--no-greeting" "--batch" - "--list-secret-keys"))) - (with-temp-buffer - (apply #'call-process pgg-gpg-program nil t nil args) - (goto-char (point-min)) - (while (re-search-forward - "^\\(sec\\|pub\\):[^:]*:[^:]*:[^:]*:\\([^:]*\\)" nil t) - (push (substring (match-string 2) 8) - pgg-gpg-all-secret-keys))))) - pgg-gpg-all-secret-keys) - -(defun pgg-gpg-lookup-key (string &optional type) - "Search keys associated with STRING." - (let ((args (list "--with-colons" "--no-greeting" "--batch" - (if type "--list-secret-keys" "--list-keys") - string))) - (with-temp-buffer - (apply #'call-process pgg-gpg-program nil t nil args) - (goto-char (point-min)) - (if (re-search-forward "^\\(sec\\|pub\\):[^:]*:[^:]*:[^:]*:\\([^:]*\\)" - nil t) - (substring (match-string 2) 8))))) - -(defun pgg-gpg-lookup-key-owner (string &optional all) - "Search keys associated with STRING and return owner of identified key. - -The value may be just the bare key id, or it may be a combination of the -user name associated with the key and the key id, with the key id enclosed -in \"<...>\" angle brackets. - -Optional ALL non-nil means search all keys, including secret keys." - (let ((args (list "--with-colons" "--no-greeting" "--batch" - (if all "--list-secret-keys" "--list-keys") - string)) - (key-regexp (concat "^\\(sec\\|pub\\|uid\\)" - ":[^:]*:[^:]*:[^:]*:\\([^:]*\\):[^:]*" - ":[^:]*:[^:]*:[^:]*:\\([^:]+\\):"))) - (with-temp-buffer - (apply #'call-process pgg-gpg-program nil t nil args) - (goto-char (point-min)) - (if (re-search-forward key-regexp - nil t) - (match-string 3))))) - -(defun pgg-gpg-key-id-from-key-owner (key-owner) - (cond ((not key-owner) nil) - ;; Extract bare key id from outermost paired angle brackets, if any: - ((string-match "[^<]*<\\(.+\\)>[^>]*" key-owner) - (substring key-owner (match-beginning 1)(match-end 1))) - (key-owner))) - -(defun pgg-gpg-encrypt-region (start end recipients &optional sign passphrase) - "Encrypt the current region between START and END. - -If optional argument SIGN is non-nil, do a combined sign and encrypt. - -If optional PASSPHRASE is not specified, it will be obtained from the -passphrase cache or user." - (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id)) - (passphrase (or passphrase - (when (and sign (not (pgg-gpg-use-agent-p))) - (pgg-read-passphrase - (format "GnuPG passphrase for %s: " - pgg-gpg-user-id) - pgg-gpg-user-id)))) - (args - (append - (list "--batch" "--armor" "--always-trust" "--encrypt") - (if pgg-text-mode (list "--textmode")) - (if sign (list "--sign" "--local-user" pgg-gpg-user-id)) - (if (or recipients pgg-encrypt-for-me) - (apply #'nconc - (mapcar (lambda (rcpt) - (list pgg-gpg-recipient-argument rcpt)) - (append recipients - (if pgg-encrypt-for-me - (list pgg-gpg-user-id))))))))) - (pgg-gpg-process-region start end passphrase pgg-gpg-program args) - (when sign - (with-current-buffer pgg-errors-buffer - ;; Possibly cache passphrase under, e.g. "jas", for future sign. - (pgg-gpg-possibly-cache-passphrase passphrase pgg-gpg-user-id) - ;; Possibly cache passphrase under, e.g. B565716F, for future decrypt. - (pgg-gpg-possibly-cache-passphrase passphrase))) - (pgg-process-when-success))) - -(defun pgg-gpg-encrypt-symmetric-region (start end &optional passphrase) - "Encrypt the current region between START and END with symmetric cipher. - -If optional PASSPHRASE is not specified, it will be obtained from the -passphrase cache or user." - (let* ((passphrase (or passphrase - (when (not (pgg-gpg-use-agent-p)) - (pgg-read-passphrase - "GnuPG passphrase for symmetric encryption: ")))) - (args - (append (list "--batch" "--armor" "--symmetric" ) - (if pgg-text-mode (list "--textmode"))))) - (pgg-gpg-process-region start end passphrase pgg-gpg-program args) - (pgg-process-when-success))) - -(defun pgg-gpg-decrypt-region (start end &optional passphrase) - "Decrypt the current region between START and END. - -If optional PASSPHRASE is not specified, it will be obtained from the -passphrase cache or user." - (let* ((current-buffer (current-buffer)) - (message-keys (with-temp-buffer - (insert-buffer-substring current-buffer) - (pgg-decode-armor-region (point-min) (point-max)))) - (secret-keys (pgg-gpg-lookup-all-secret-keys)) - ;; XXX the user is stuck if they need to use the passphrase for - ;; any but the first secret key for which the message is - ;; encrypted. ideally, we would incrementally give them a - ;; chance with subsequent keys each time they fail with one. - (key (pgg-gpg-select-matching-key message-keys secret-keys)) - (key-owner (and key (pgg-gpg-lookup-key-owner key t))) - (key-id (pgg-gpg-key-id-from-key-owner key-owner)) - (pgg-gpg-user-id (or key-id key - pgg-gpg-user-id pgg-default-user-id)) - (passphrase (or passphrase - (when (not (pgg-gpg-use-agent-p)) - (pgg-read-passphrase - (format (if (pgg-gpg-symmetric-key-p message-keys) - "Passphrase for symmetric decryption: " - "GnuPG passphrase for %s: ") - (or key-owner "??")) - pgg-gpg-user-id)))) - (args '("--batch" "--decrypt"))) - (pgg-gpg-process-region start end passphrase pgg-gpg-program args) - (with-current-buffer pgg-errors-buffer - (pgg-gpg-possibly-cache-passphrase passphrase pgg-gpg-user-id) - (goto-char (point-min)) - (re-search-forward "^\\[GNUPG:] DECRYPTION_OKAY\\>" nil t)))) - -;;;###autoload -(defun pgg-gpg-symmetric-key-p (message-keys) - "True if decoded armor MESSAGE-KEYS has symmetric encryption indicator." - (let (result) - (dolist (key message-keys result) - (when (and (eq (car key) 3) - (member '(symmetric-key-algorithm) key)) - (setq result key))))) - -(defun pgg-gpg-select-matching-key (message-keys secret-keys) - "Choose a key from MESSAGE-KEYS that matches one of the keys in SECRET-KEYS." - (loop for message-key in message-keys - for message-key-id = (and (equal (car message-key) 1) - (cdr (assq 'key-identifier - (cdr message-key)))) - for key = (and message-key-id (pgg-lookup-key message-key-id 'encrypt)) - when (and key (member key secret-keys)) return key)) - -(defun pgg-gpg-sign-region (start end &optional cleartext passphrase) - "Make detached signature from text between START and END." - (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id)) - (passphrase (or passphrase - (when (not (pgg-gpg-use-agent-p)) - (pgg-read-passphrase - (format "GnuPG passphrase for %s: " - pgg-gpg-user-id) - pgg-gpg-user-id)))) - (args - (append (list (if cleartext "--clearsign" "--detach-sign") - "--armor" "--batch" "--verbose" - "--local-user" pgg-gpg-user-id) - (if pgg-text-mode (list "--textmode")))) - (inhibit-read-only t) - buffer-read-only) - (pgg-gpg-process-region start end passphrase pgg-gpg-program args) - (with-current-buffer pgg-errors-buffer - ;; Possibly cache passphrase under, e.g. "jas", for future sign. - (pgg-gpg-possibly-cache-passphrase passphrase pgg-gpg-user-id) - ;; Possibly cache passphrase under, e.g. B565716F, for future decrypt. - (pgg-gpg-possibly-cache-passphrase passphrase)) - (pgg-process-when-success))) - -(defun pgg-gpg-verify-region (start end &optional signature) - "Verify region between START and END as the detached signature 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) - (with-current-buffer pgg-errors-buffer - (goto-char (point-min)) - (while (re-search-forward "^gpg: \\(.*\\)\n" nil t) - (with-current-buffer pgg-output-buffer - (insert-buffer-substring pgg-errors-buffer - (match-beginning 1) (match-end 0))) - (delete-region (match-beginning 0) (match-end 0))) - (goto-char (point-min)) - (re-search-forward "^\\[GNUPG:] GOODSIG\\>" nil t)))) - -(defun pgg-gpg-insert-key () - "Insert public key at point." - (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id)) - (args (list "--batch" "--export" "--armor" - pgg-gpg-user-id))) - (pgg-gpg-process-region (point)(point) nil pgg-gpg-program args) - (insert-buffer-substring pgg-output-buffer))) - -(defun pgg-gpg-snarf-keys-region (start end) - "Add all public keys in region between START and END to the keyring." - (let ((args '("--import" "--batch" "-")) status) - (pgg-gpg-process-region start end nil pgg-gpg-program args) - (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-number (split-string status)))) - (erase-buffer) - (insert (format "Imported %d key(s). -\tArmor contains %d key(s) [%d bad, %d old].\n" - (+ (aref status 2) - (aref status 10)) - (aref status 0) - (aref status 1) - (+ (aref status 4) - (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))) - -(defun pgg-gpg-update-agent () - "Try to connet to gpg-agent and send UPDATESTARTUPTTY." - (if (fboundp 'make-network-process) - (let* ((agent-info (getenv "GPG_AGENT_INFO")) - (socket (and agent-info - (string-match "^\\([^:]*\\)" agent-info) - (match-string 1 agent-info))) - (conn (and socket - (make-network-process :name "gpg-agent-process" - :host 'local :family 'local - :service socket)))) - (when (and conn (eq (process-status conn) 'open)) - (process-send-string conn "UPDATESTARTUPTTY\n") - (delete-process conn) - t)) - ;; We can't check, so assume gpg-agent is up. - t)) - -(defun pgg-gpg-use-agent-p () - "Return t if `pgg-gpg-use-agent' is t and gpg-agent is available." - (and pgg-gpg-use-agent (pgg-gpg-update-agent))) - -(provide 'pgg-gpg) - -;;; pgg-gpg.el ends here diff -r 7a4b15c4bbed -r 62f897baec0a lisp/pgg-parse.el --- a/lisp/pgg-parse.el Mon Dec 20 22:12:30 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,523 +0,0 @@ -;;; pgg-parse.el --- OpenPGP packet parsing - -;; Copyright (C) 1999, 2002, 2003, 2004, 2005, -;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. - -;; Author: Daiki Ueno -;; Created: 1999/10/28 -;; Keywords: PGP, OpenPGP, GnuPG -;; Package: pgg - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see . - -;;; Commentary: - -;; This module is based on - -;; [OpenPGP] RFC 2440: "OpenPGP Message Format" -;; by John W. Noerenberg, II , -;; Jon Callas , Lutz Donnerhacke , -;; Hal Finney and Rodney Thayer -;; (1998/11) - -;;; Code: - -(eval-when-compile - ;; For Emacs <22.2 and XEmacs. - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))) - (require 'cl)) - -(defgroup pgg-parse () - "OpenPGP packet parsing." - :group 'pgg) - -(defcustom pgg-parse-public-key-algorithm-alist - '((1 . RSA) (2 . RSA-E) (3 . RSA-S) (16 . ELG-E) (17 . DSA) (20 . ELG)) - "Alist of the assigned number to the public key algorithm." - :group 'pgg-parse - :type '(repeat - (cons (sexp :tag "Number") (sexp :tag "Type")))) - -(defcustom pgg-parse-symmetric-key-algorithm-alist - '((1 . IDEA) (2 . 3DES) (4 . CAST5) (5 . SAFER-SK128)) - "Alist of the assigned number to the simmetric key algorithm." - :group 'pgg-parse - :type '(repeat - (cons (sexp :tag "Number") (sexp :tag "Type")))) - -(defcustom pgg-parse-hash-algorithm-alist - '((1 . MD5) (2 . SHA1) (3 . RIPEMD160) (5 . MD2) (8 . SHA256) (9 . SHA384) - (10 . SHA512)) - "Alist of the assigned number to the cryptographic hash algorithm." - :group 'pgg-parse - :type '(repeat - (cons (sexp :tag "Number") (sexp :tag "Type")))) - -(defcustom pgg-parse-compression-algorithm-alist - '((0 . nil); Uncompressed - (1 . ZIP) - (2 . ZLIB)) - "Alist of the assigned number to the compression algorithm." - :group 'pgg-parse - :type '(repeat - (cons (sexp :tag "Number") (sexp :tag "Type")))) - -(defcustom pgg-parse-signature-type-alist - '((0 . "Signature of a binary document") - (1 . "Signature of a canonical text document") - (2 . "Standalone signature") - (16 . "Generic certification of a User ID and Public Key packet") - (17 . "Persona certification of a User ID and Public Key packet") - (18 . "Casual certification of a User ID and Public Key packet") - (19 . "Positive certification of a User ID and Public Key packet") - (24 . "Subkey Binding Signature") - (31 . "Signature directly on a key") - (32 . "Key revocation signature") - (40 . "Subkey revocation signature") - (48 . "Certification revocation signature") - (64 . "Timestamp signature.")) - "Alist of the assigned number to the signature type." - :group 'pgg-parse - :type '(repeat - (cons (sexp :tag "Number") (sexp :tag "Type")))) - -(defcustom pgg-ignore-packet-checksum t; XXX - "If non-nil checksum of each ascii armored packet will be ignored." - :group 'pgg-parse - :type 'boolean) - -(defvar pgg-armor-header-lines - '("^-----BEGIN PGP MESSAGE\\(, PART [0-9]+\\(/[0-9]+\\)?\\)?-----\r?$" - "^-----BEGIN PGP PUBLIC KEY BLOCK-----\r?$" - "^-----BEGIN PGP PRIVATE KEY BLOCK-----\r?$" - "^-----BEGIN PGP SIGNATURE-----\r?$") - "Armor headers.") - -(eval-and-compile - (defalias 'pgg-char-int (if (fboundp 'char-int) - 'char-int - 'identity))) - -(defmacro pgg-format-key-identifier (string) - `(mapconcat (lambda (c) (format "%02X" (pgg-char-int c))) - ,string "") - ;; `(upcase (apply #'format "%02x%02x%02x%02x%02x%02x%02x%02x" - ;; (string-to-number-list ,string))) - ) - -(defmacro pgg-parse-time-field (bytes) - `(list (logior (lsh (car ,bytes) 8) - (nth 1 ,bytes)) - (logior (lsh (nth 2 ,bytes) 8) - (nth 3 ,bytes)) - 0)) - -(defmacro pgg-byte-after (&optional pos) - `(pgg-char-int (char-after ,(or pos `(point))))) - -(defmacro pgg-read-byte () - `(pgg-char-int (char-after (prog1 (point) (forward-char))))) - -(defmacro pgg-read-bytes-string (nbytes) - `(buffer-substring - (point) (prog1 (+ ,nbytes (point)) - (forward-char ,nbytes)))) - -(defmacro pgg-read-bytes (nbytes) - `(mapcar #'pgg-char-int (pgg-read-bytes-string ,nbytes)) - ;; `(string-to-number-list (pgg-read-bytes-string ,nbytes)) - ) - -(defmacro pgg-read-body-string (ptag) - `(if (nth 1 ,ptag) - (pgg-read-bytes-string (nth 1 ,ptag)) - (pgg-read-bytes-string (- (point-max) (point))))) - -(defmacro pgg-read-body (ptag) - `(mapcar #'pgg-char-int (pgg-read-body-string ,ptag)) - ;; `(string-to-number-list (pgg-read-body-string ,ptag)) - ) - -(defalias 'pgg-skip-bytes 'forward-char) - -(defmacro pgg-skip-header (ptag) - `(pgg-skip-bytes (nth 2 ,ptag))) - -(defmacro pgg-skip-body (ptag) - `(pgg-skip-bytes (nth 1 ,ptag))) - -(defmacro pgg-set-alist (alist key value) - `(setq ,alist (nconc ,alist (list (cons ,key ,value))))) - -(when (fboundp 'define-ccl-program) - - (define-ccl-program pgg-parse-crc24 - '(1 - ((loop - (read r0) (r1 ^= r0) (r2 ^= 0) - (r5 = 0) - (loop - (r1 <<= 1) - (r1 += ((r2 >> 15) & 1)) - (r2 <<= 1) - (if (r1 & 256) - ((r1 ^= 390) (r2 ^= 19707))) - (if (r5 < 7) - ((r5 += 1) - (repeat)))) - (repeat))))) - - (defvar pgg-parse-crc24) - - (defun pgg-parse-crc24-string (string) - (let ((h (vector nil 183 1230 nil nil nil nil nil nil))) - (ccl-execute-on-string pgg-parse-crc24 h string) - (format "%c%c%c" - (logand (aref h 1) 255) - (logand (lsh (aref h 2) -8) 255) - (logand (aref h 2) 255))))) - -(defmacro pgg-parse-length-type (c) - `(cond - ((< ,c 192) (cons ,c 1)) - ((< ,c 224) - (cons (+ (lsh (- ,c 192) 8) - (pgg-byte-after (+ 2 (point))) - 192) - 2)) - ((= ,c 255) - (cons (cons (logior (lsh (pgg-byte-after (+ 2 (point))) 8) - (pgg-byte-after (+ 3 (point)))) - (logior (lsh (pgg-byte-after (+ 4 (point))) 8) - (pgg-byte-after (+ 5 (point))))) - 5)) - (t;partial body length - '(0 . 0)))) - -(defun pgg-parse-packet-header () - (let ((ptag (pgg-byte-after)) - length-type content-tag packet-bytes header-bytes) - (if (zerop (logand 64 ptag));Old format - (progn - (setq length-type (logand ptag 3) - length-type (if (= 3 length-type) 0 (lsh 1 length-type)) - content-tag (logand 15 (lsh ptag -2)) - packet-bytes 0 - header-bytes (1+ length-type)) - (dotimes (i length-type) - (setq packet-bytes - (logior (lsh packet-bytes 8) - (pgg-byte-after (+ 1 i (point))))))) - (setq content-tag (logand 63 ptag) - length-type (pgg-parse-length-type - (pgg-byte-after (1+ (point)))) - packet-bytes (car length-type) - header-bytes (1+ (cdr length-type)))) - (list content-tag packet-bytes header-bytes))) - -(defun pgg-parse-packet (ptag) - (case (car ptag) - (1 ;Public-Key Encrypted Session Key Packet - (pgg-parse-public-key-encrypted-session-key-packet ptag)) - (2 ;Signature Packet - (pgg-parse-signature-packet ptag)) - (3 ;Symmetric-Key Encrypted Session Key Packet - (pgg-parse-symmetric-key-encrypted-session-key-packet ptag)) - ;; 4 -- One-Pass Signature Packet - ;; 5 -- Secret Key Packet - (6 ;Public Key Packet - (pgg-parse-public-key-packet ptag)) - ;; 7 -- Secret Subkey Packet - ;; 8 -- Compressed Data Packet - (9 ;Symmetrically Encrypted Data Packet - (pgg-read-body-string ptag)) - (10 ;Marker Packet - (pgg-read-body-string ptag)) - (11 ;Literal Data Packet - (pgg-read-body-string ptag)) - ;; 12 -- Trust Packet - (13 ;User ID Packet - (pgg-read-body-string ptag)) - ;; 14 -- Public Subkey Packet - ;; 60 .. 63 -- Private or Experimental Values - )) - -(defun pgg-parse-packets (&optional header-parser body-parser) - (let ((header-parser - (or header-parser - (function pgg-parse-packet-header))) - (body-parser - (or body-parser - (function pgg-parse-packet))) - result ptag) - (while (> (point-max) (1+ (point))) - (setq ptag (funcall header-parser)) - (pgg-skip-header ptag) - (push (cons (car ptag) - (save-excursion - (funcall body-parser ptag))) - result) - (if (zerop (nth 1 ptag)) - (goto-char (point-max)) - (forward-char (nth 1 ptag)))) - result)) - -(defun pgg-parse-signature-subpacket-header () - (let ((length-type (pgg-parse-length-type (pgg-byte-after)))) - (list (pgg-byte-after (+ (cdr length-type) (point))) - (1- (car length-type)) - (1+ (cdr length-type))))) - -(defun pgg-parse-signature-subpacket (ptag) - (case (car ptag) - (2 ;signature creation time - (cons 'creation-time - (let ((bytes (pgg-read-bytes 4))) - (pgg-parse-time-field bytes)))) - (3 ;signature expiration time - (cons 'signature-expiry - (let ((bytes (pgg-read-bytes 4))) - (pgg-parse-time-field bytes)))) - (4 ;exportable certification - (cons 'exportability (pgg-read-byte))) - (5 ;trust signature - (cons 'trust-level (pgg-read-byte))) - (6 ;regular expression - (cons 'regular-expression - (pgg-read-body-string ptag))) - (7 ;revocable - (cons 'revocability (pgg-read-byte))) - (9 ;key expiration time - (cons 'key-expiry - (let ((bytes (pgg-read-bytes 4))) - (pgg-parse-time-field bytes)))) - ;; 10 = placeholder for backward compatibility - (11 ;preferred symmetric algorithms - (cons 'preferred-symmetric-key-algorithm - (cdr (assq (pgg-read-byte) - pgg-parse-symmetric-key-algorithm-alist)))) - (12 ;revocation key - ) - (16 ;issuer key ID - (cons 'key-identifier - (pgg-format-key-identifier (pgg-read-body-string ptag)))) - (20 ;notation data - (pgg-skip-bytes 4) - (cons 'notation - (let ((name-bytes (pgg-read-bytes 2)) - (value-bytes (pgg-read-bytes 2))) - (cons (pgg-read-bytes-string - (logior (lsh (car name-bytes) 8) - (nth 1 name-bytes))) - (pgg-read-bytes-string - (logior (lsh (car value-bytes) 8) - (nth 1 value-bytes))))))) - (21 ;preferred hash algorithms - (cons 'preferred-hash-algorithm - (cdr (assq (pgg-read-byte) - pgg-parse-hash-algorithm-alist)))) - (22 ;preferred compression algorithms - (cons 'preferred-compression-algorithm - (cdr (assq (pgg-read-byte) - pgg-parse-compression-algorithm-alist)))) - (23 ;key server preferences - (cons 'key-server-preferences - (pgg-read-body ptag))) - (24 ;preferred key server - (cons 'preferred-key-server - (pgg-read-body-string ptag))) - ;; 25 = primary user id - (26 ;policy URL - (cons 'policy-url (pgg-read-body-string ptag))) - ;; 27 = key flags - ;; 28 = signer's user id - ;; 29 = reason for revocation - ;; 100 to 110 = internal or user-defined - )) - -(defun pgg-parse-signature-packet (ptag) - (let* ((signature-version (pgg-byte-after)) - (result (list (cons 'version signature-version))) - hashed-material field n) - (cond - ((= signature-version 3) - (pgg-skip-bytes 2) - (setq hashed-material (pgg-read-bytes 5)) - (pgg-set-alist result - 'signature-type - (cdr (assq (pop hashed-material) - pgg-parse-signature-type-alist))) - (pgg-set-alist result - 'creation-time - (pgg-parse-time-field hashed-material)) - (pgg-set-alist result - 'key-identifier - (pgg-format-key-identifier - (pgg-read-bytes-string 8))) - (pgg-set-alist result - 'public-key-algorithm (pgg-read-byte)) - (pgg-set-alist result - 'hash-algorithm (pgg-read-byte))) - ((= signature-version 4) - (pgg-skip-bytes 1) - (pgg-set-alist result - 'signature-type - (cdr (assq (pgg-read-byte) - pgg-parse-signature-type-alist))) - (pgg-set-alist result - 'public-key-algorithm - (pgg-read-byte)) - (pgg-set-alist result - 'hash-algorithm (pgg-read-byte)) - (when (>= 10000 (setq n (pgg-read-bytes 2) - n (logior (lsh (car n) 8) - (nth 1 n)))) - (save-restriction - (narrow-to-region (point)(+ n (point))) - (nconc result - (mapcar (function cdr) ;remove packet types - (pgg-parse-packets - #'pgg-parse-signature-subpacket-header - #'pgg-parse-signature-subpacket))) - (goto-char (point-max)))) - (when (>= 10000 (setq n (pgg-read-bytes 2) - n (logior (lsh (car n) 8) - (nth 1 n)))) - (save-restriction - (narrow-to-region (point)(+ n (point))) - (nconc result - (mapcar (function cdr) ;remove packet types - (pgg-parse-packets - #'pgg-parse-signature-subpacket-header - #'pgg-parse-signature-subpacket))))))) - - (setcdr (setq field (assq 'public-key-algorithm - result)) - (cdr (assq (cdr field) - pgg-parse-public-key-algorithm-alist))) - (setcdr (setq field (assq 'hash-algorithm - result)) - (cdr (assq (cdr field) - pgg-parse-hash-algorithm-alist))) - result)) - -(defun pgg-parse-public-key-encrypted-session-key-packet (ptag) - (let (result) - (pgg-set-alist result - 'version (pgg-read-byte)) - (pgg-set-alist result - 'key-identifier - (pgg-format-key-identifier - (pgg-read-bytes-string 8))) - (pgg-set-alist result - 'public-key-algorithm - (cdr (assq (pgg-read-byte) - pgg-parse-public-key-algorithm-alist))) - result)) - -(defun pgg-parse-symmetric-key-encrypted-session-key-packet (ptag) - (let (result) - (pgg-set-alist result - 'version - (pgg-read-byte)) - (pgg-set-alist result - 'symmetric-key-algorithm - (cdr (assq (pgg-read-byte) - pgg-parse-symmetric-key-algorithm-alist))) - result)) - -(defun pgg-parse-public-key-packet (ptag) - (let* ((key-version (pgg-read-byte)) - (result (list (cons 'version key-version))) - field) - (cond - ((= 3 key-version) - (pgg-set-alist result - 'creation-time - (let ((bytes (pgg-read-bytes 4))) - (pgg-parse-time-field bytes))) - (pgg-set-alist result - 'key-expiry (pgg-read-bytes 2)) - (pgg-set-alist result - 'public-key-algorithm (pgg-read-byte))) - ((= 4 key-version) - (pgg-set-alist result - 'creation-time - (let ((bytes (pgg-read-bytes 4))) - (pgg-parse-time-field bytes))) - (pgg-set-alist result - 'public-key-algorithm (pgg-read-byte)))) - - (setcdr (setq field (assq 'public-key-algorithm - result)) - (cdr (assq (cdr field) - pgg-parse-public-key-algorithm-alist))) - result)) - -;; p-d-p only calls this if it is defined, but the compiler does not -;; recognize that. -(declare-function pgg-parse-crc24-string "pgg-parse" (string)) - -(defun pgg-decode-packets () - (if (re-search-forward "^=\\([A-Za-z0-9+/]\\{4\\}\\)$" nil t) - (let ((p (match-beginning 0)) - (checksum (match-string 1))) - (delete-region p (point-max)) - (if (ignore-errors (base64-decode-region (point-min) p)) - (or (not (fboundp 'pgg-parse-crc24-string)) - pgg-ignore-packet-checksum - (string-equal (base64-encode-string (pgg-parse-crc24-string - (buffer-string))) - checksum) - (progn - (message "PGP packet checksum does not match") - nil)) - (message "PGP packet contain invalid base64") - nil)) - (message "PGP packet checksum not found") - nil)) - -(defun pgg-decode-armor-region (start end) - (save-restriction - (narrow-to-region start end) - (goto-char (point-min)) - (re-search-forward "^-+BEGIN PGP" nil t) - (delete-region (point-min) - (and (search-forward "\n\n") - (match-end 0))) - (when (pgg-decode-packets) - (goto-char (point-min)) - (pgg-parse-packets)))) - -(defun pgg-parse-armor (string) - (with-temp-buffer - (buffer-disable-undo) - (unless (featurep 'xemacs) - (set-buffer-multibyte nil)) - (insert string) - (pgg-decode-armor-region (point-min)(point)))) - -(eval-and-compile - (defalias 'pgg-string-as-unibyte (if (fboundp 'string-as-unibyte) - 'string-as-unibyte - 'identity))) - -(defun pgg-parse-armor-region (start end) - (pgg-parse-armor (pgg-string-as-unibyte (buffer-substring start end)))) - -(provide 'pgg-parse) - -;;; pgg-parse.el ends here diff -r 7a4b15c4bbed -r 62f897baec0a lisp/pgg-pgp.el --- a/lisp/pgg-pgp.el Mon Dec 20 22:12:30 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,257 +0,0 @@ -;;; pgg-pgp.el --- PGP 2.* and 6.* support for PGG. - -;; Copyright (C) 1999, 2000, 2002, 2003, 2004, 2005, 2006, 2007, 2008, -;; 2009, 2010 Free Software Foundation, Inc. - -;; Author: Daiki Ueno -;; Created: 1999/11/02 -;; Keywords: PGP, OpenPGP -;; Package: pgg - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see . - -;;; Code: - -(eval-when-compile - (require 'cl) ; for pgg macros - (require 'pgg)) - -(defgroup pgg-pgp () - "PGP 2.* and 6.* interface." - :group 'pgg) - -(defcustom pgg-pgp-program "pgp" - "PGP 2.* and 6.* executable." - :group 'pgg-pgp - :type 'string) - -(defcustom pgg-pgp-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-pgp - :type 'string) - -(defcustom pgg-pgp-shell-command-switch "-c" - "Switch used to have the shell execute its command line argument." - :group 'pgg-pgp - :type 'string) - -(defcustom pgg-pgp-extra-args nil - "Extra arguments for every PGP invocation." - :group 'pgg-pgp - :type '(choice - (const :tag "None" nil) - (string :tag "Arguments"))) - -(defvar pgg-pgp-user-id nil - "PGP ID of your default identity.") - -(defun pgg-pgp-process-region (start end passphrase program args) - (let* ((errors-file-name (pgg-make-temp-file "pgg-errors")) - (args - (concat args - pgg-pgp-extra-args - " 2>" (shell-quote-argument errors-file-name))) - (shell-file-name pgg-pgp-shell-file-name) - (shell-command-switch pgg-pgp-shell-command-switch) - (process-environment process-environment) - (output-buffer pgg-output-buffer) - (errors-buffer pgg-errors-buffer) - (process-connection-type nil) - process status exit-status) - (with-current-buffer (get-buffer-create output-buffer) - (buffer-disable-undo) - (erase-buffer)) - (when passphrase - (setenv "PGPPASSFD" "0")) - (unwind-protect - (progn - (let ((coding-system-for-read 'binary) - (coding-system-for-write 'binary)) - (setq process - (start-process-shell-command "*PGP*" output-buffer - (concat 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))) - (if (and process (eq 'run (process-status process))) - (interrupt-process process)) - (condition-case nil - (delete-file errors-file-name) - (file-error nil))))) - -(defun pgg-pgp-lookup-key (string &optional type) - "Search keys associated with STRING." - (let ((args (list "+batchmode" "+language=en" "-kv" string))) - (with-current-buffer (get-buffer-create pgg-output-buffer) - (buffer-disable-undo) - (erase-buffer) - (apply #'call-process pgg-pgp-program nil t nil args) - (goto-char (point-min)) - (cond - ((re-search-forward "^pub\\s +[0-9]+/" nil t);PGP 2.* - (buffer-substring (point)(+ 8 (point)))) - ((re-search-forward "^Type" nil t);PGP 6.* - (beginning-of-line 2) - (substring - (nth 2 (split-string - (buffer-substring (point)(progn (end-of-line) (point))))) - 2)))))) - -(defun pgg-pgp-encrypt-region (start end recipients &optional sign passphrase) - "Encrypt the current region between START and END." - (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id)) - (passphrase (or passphrase - (when sign - (pgg-read-passphrase - (format "PGP passphrase for %s: " - pgg-pgp-user-id) - pgg-pgp-user-id)))) - (args - (concat - "+encrypttoself=off +verbose=1 +batchmode +language=us -fate " - (if (or recipients pgg-encrypt-for-me) - (mapconcat 'shell-quote-argument - (append recipients - (if pgg-encrypt-for-me - (list pgg-pgp-user-id))) " ")) - (if sign (concat " -s -u " (shell-quote-argument pgg-pgp-user-id)))))) - (pgg-pgp-process-region start end nil pgg-pgp-program args) - (pgg-process-when-success nil))) - -(defun pgg-pgp-decrypt-region (start end &optional passphrase) - "Decrypt the current region between START and END. - -If optional PASSPHRASE is not specified, it will be obtained from the -passphrase cache or user." - (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id)) - (key (pgg-pgp-lookup-key pgg-pgp-user-id 'encrypt)) - (passphrase - (or passphrase - (pgg-read-passphrase - (format "PGP passphrase for %s: " pgg-pgp-user-id) key))) - (args - "+verbose=1 +batchmode +language=us -f")) - (pgg-pgp-process-region start end passphrase pgg-pgp-program args) - (pgg-process-when-success - (if pgg-cache-passphrase - (pgg-add-passphrase-to-cache key passphrase))))) - -(defun pgg-pgp-sign-region (start end &optional clearsign passphrase) - "Make detached signature from text between START and END. - -If optional PASSPHRASE is not specified, it will be obtained from the -passphrase cache or user." - (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id)) - (passphrase - (or passphrase - (pgg-read-passphrase - (format "PGP passphrase for %s: " pgg-pgp-user-id) - (pgg-pgp-lookup-key pgg-pgp-user-id 'sign)))) - (args - (concat (if clearsign "-fast" "-fbast") - " +verbose=1 +language=us +batchmode" - " -u " (shell-quote-argument pgg-pgp-user-id)))) - (pgg-pgp-process-region start end passphrase pgg-pgp-program args) - (pgg-process-when-success - (goto-char (point-min)) - (when (re-search-forward "^-+BEGIN PGP" 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-to-cache - (cdr (assq 'key-identifier packet)) - passphrase))))))) - -(defun pgg-pgp-verify-region (start end &optional signature) - "Verify region between START and END as the detached signature SIGNATURE." - (let* ((orig-file (pgg-make-temp-file "pgg")) - (args "+verbose=1 +batchmode +language=us") - (orig-mode (default-file-modes))) - (unwind-protect - (progn - (set-default-file-modes 448) - (let ((coding-system-for-write 'binary) - jka-compr-compression-info-list jam-zcat-filename-list) - (write-region start end orig-file))) - (set-default-file-modes orig-mode)) - (if (stringp signature) - (progn - (copy-file signature (setq signature (concat orig-file ".asc"))) - (setq args (concat args " " (shell-quote-argument signature))))) - (setq args (concat args " " (shell-quote-argument orig-file))) - (pgg-pgp-process-region (point)(point) nil pgg-pgp-program args) - (delete-file orig-file) - (if signature (delete-file signature)) - (pgg-process-when-success - (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))))) - (goto-char (point-min)) - (when (re-search-forward "^\\.$" nil t) - (delete-region (point-min) - (progn (beginning-of-line 2) - (point))))))) - -(defun pgg-pgp-insert-key () - "Insert public key at point." - (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id)) - (args - (concat "+verbose=1 +batchmode +language=us -kxaf " - (shell-quote-argument pgg-pgp-user-id)))) - (pgg-pgp-process-region (point)(point) nil pgg-pgp-program args) - (insert-buffer-substring pgg-output-buffer))) - -(defun pgg-pgp-snarf-keys-region (start end) - "Add all public keys in region between START and END to the keyring." - (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id)) - (key-file (pgg-make-temp-file "pgg")) - (args - (concat "+verbose=1 +batchmode +language=us -kaf " - (shell-quote-argument key-file)))) - (let ((coding-system-for-write 'raw-text-dos)) - (write-region start end key-file)) - (pgg-pgp-process-region start end nil pgg-pgp-program args) - (delete-file key-file) - (pgg-process-when-success nil))) - -(provide 'pgg-pgp) - -;;; pgg-pgp.el ends here diff -r 7a4b15c4bbed -r 62f897baec0a lisp/pgg-pgp5.el --- a/lisp/pgg-pgp5.el Mon Dec 20 22:12:30 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,258 +0,0 @@ -;;; pgg-pgp5.el --- PGP 5.* support for PGG. - -;; Copyright (C) 1999, 2000, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. - -;; Author: Daiki Ueno -;; Created: 1999/11/02 -;; Keywords: PGP, OpenPGP -;; Package: pgg - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see . - -;;; Code: - -(eval-when-compile - (require 'cl) ; for pgg macros - (require 'pgg)) - -(defgroup pgg-pgp5 () - "PGP 5.* interface." - :group 'pgg) - -(defcustom pgg-pgp5-pgpe-program "pgpe" - "PGP 5.* 'pgpe' executable." - :group 'pgg-pgp5 - :type 'string) - -(defcustom pgg-pgp5-pgps-program "pgps" - "PGP 5.* 'pgps' executable." - :group 'pgg-pgp5 - :type 'string) - -(defcustom pgg-pgp5-pgpk-program "pgpk" - "PGP 5.* 'pgpk' executable." - :group 'pgg-pgp5 - :type 'string) - -(defcustom pgg-pgp5-pgpv-program "pgpv" - "PGP 5.* 'pgpv' executable." - :group 'pgg-pgp5 - :type 'string) - -(defcustom pgg-pgp5-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-pgp5 - :type 'string) - -(defcustom pgg-pgp5-shell-command-switch "-c" - "Switch used to have the shell execute its command line argument." - :group 'pgg-pgp5 - :type 'string) - -(defcustom pgg-pgp5-extra-args nil - "Extra arguments for every PGP 5.* invocation." - :group 'pgg-pgp5 - :type '(choice - (const :tag "None" nil) - (string :tag "Arguments"))) - -(defvar pgg-pgp5-user-id nil - "PGP 5.* ID of your default identity.") - -(defun pgg-pgp5-process-region (start end passphrase program args) - (let* ((errors-file-name (pgg-make-temp-file "pgg-errors")) - (args - (append args - pgg-pgp5-extra-args - (list (concat "2>" errors-file-name)))) - (shell-file-name pgg-pgp5-shell-file-name) - (shell-command-switch pgg-pgp5-shell-command-switch) - (process-environment process-environment) - (output-buffer pgg-output-buffer) - (errors-buffer pgg-errors-buffer) - (process-connection-type nil) - process status exit-status) - (with-current-buffer (get-buffer-create output-buffer) - (buffer-disable-undo) - (erase-buffer)) - (when passphrase - (setenv "PGPPASSFD" "0")) - (unwind-protect - (progn - (let ((coding-system-for-read 'binary) - (coding-system-for-write 'binary)) - (setq process - (apply #'funcall - #'start-process-shell-command "*PGP*" 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))) - (if (and process (eq 'run (process-status process))) - (interrupt-process process)) - (condition-case nil - (delete-file errors-file-name) - (file-error nil))))) - -(defun pgg-pgp5-lookup-key (string &optional type) - "Search keys associated with STRING." - (let ((args (list "+language=en" "-l" string))) - (with-current-buffer (get-buffer-create pgg-output-buffer) - (buffer-disable-undo) - (erase-buffer) - (apply #'call-process pgg-pgp5-pgpk-program nil t nil args) - (goto-char (point-min)) - (when (re-search-forward "^sec" nil t) - (substring - (nth 2 (split-string - (buffer-substring (match-end 0)(progn (end-of-line)(point))))) - 2))))) - -(defun pgg-pgp5-encrypt-region (start end recipients &optional sign passphrase) - "Encrypt the current region between START and END." - (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) - (passphrase (or passphrase - (when sign - (pgg-read-passphrase - (format "PGP passphrase for %s: " - pgg-pgp5-user-id) - pgg-pgp5-user-id)))) - (args - (append - `("+NoBatchInvalidKeys=off" "-fat" "+batchmode=1" - ,@(if (or recipients pgg-encrypt-for-me) - (apply #'append - (mapcar (lambda (rcpt) - (list "-r" - (concat "\"" rcpt "\""))) - (append recipients - (if pgg-encrypt-for-me - (list pgg-pgp5-user-id))))))) - (if sign '("-s" "-u" pgg-pgp5-user-id))))) - (pgg-pgp5-process-region start end nil pgg-pgp5-pgpe-program args) - (pgg-process-when-success nil))) - -(defun pgg-pgp5-decrypt-region (start end &optional passphrase) - "Decrypt the current region between START and END." - (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) - (passphrase - (or passphrase - (pgg-read-passphrase - (format "PGP passphrase for %s: " pgg-pgp5-user-id) - (pgg-pgp5-lookup-key pgg-pgp5-user-id 'encrypt)))) - (args - '("+verbose=1" "+batchmode=1" "+language=us" "-f"))) - (pgg-pgp5-process-region start end passphrase pgg-pgp5-pgpv-program args) - (pgg-process-when-success nil))) - -(defun pgg-pgp5-sign-region (start end &optional clearsign passphrase) - "Make detached signature from text between START and END." - (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) - (passphrase - (or passphrase - (pgg-read-passphrase - (format "PGP passphrase for %s: " pgg-pgp5-user-id) - (pgg-pgp5-lookup-key pgg-pgp5-user-id 'sign)))) - (args - (list (if clearsign "-fat" "-fbat") - "+verbose=1" "+language=us" "+batchmode=1" - "-u" pgg-pgp5-user-id))) - (pgg-pgp5-process-region start end passphrase pgg-pgp5-pgps-program args) - (pgg-process-when-success - (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-to-cache - (cdr (assq 'key-identifier packet)) - passphrase))))))) - -(defun pgg-pgp5-verify-region (start end &optional signature) - "Verify region between START and END as the detached signature SIGNATURE." - (let ((orig-file (pgg-make-temp-file "pgg")) - (args '("+verbose=1" "+batchmode=1" "+language=us")) - (orig-mode (default-file-modes))) - (unwind-protect - (progn - (set-default-file-modes 448) - (let ((coding-system-for-write 'binary) - jka-compr-compression-info-list jam-zcat-filename-list) - (write-region start end orig-file))) - (set-default-file-modes orig-mode)) - (when (stringp signature) - (copy-file signature (setq signature (concat orig-file ".asc"))) - (setq args (append args (list signature)))) - (pgg-pgp5-process-region (point)(point) nil pgg-pgp5-pgpv-program args) - (delete-file orig-file) - (if signature (delete-file signature)) - (with-current-buffer pgg-errors-buffer - (goto-char (point-min)) - (if (re-search-forward "^Good signature" nil t) - (progn - (set-buffer pgg-output-buffer) - (insert-buffer-substring pgg-errors-buffer) - t) - nil)))) - -(defun pgg-pgp5-insert-key () - "Insert public key at point." - (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) - (args - (list "+verbose=1" "+batchmode=1" "+language=us" "-x" - (concat "\"" pgg-pgp5-user-id "\"")))) - (pgg-pgp5-process-region (point)(point) nil pgg-pgp5-pgpk-program args) - (insert-buffer-substring pgg-output-buffer))) - -(defun pgg-pgp5-snarf-keys-region (start end) - "Add all public keys in region between START and END to the keyring." - (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) - (key-file (pgg-make-temp-file "pgg")) - (args - (list "+verbose=1" "+batchmode=1" "+language=us" "-a" - key-file))) - (let ((coding-system-for-write 'raw-text-dos)) - (write-region start end key-file)) - (pgg-pgp5-process-region start end nil pgg-pgp5-pgpk-program args) - (delete-file key-file) - (pgg-process-when-success nil))) - -(provide 'pgg-pgp5) - -;;; pgg-pgp5.el ends here diff -r 7a4b15c4bbed -r 62f897baec0a lisp/pgg.el --- a/lisp/pgg.el Mon Dec 20 22:12:30 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,604 +0,0 @@ -;;; pgg.el --- glue for the various PGP implementations. - -;; Copyright (C) 1999, 2000, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. - -;; Author: Daiki Ueno -;; Symmetric encryption added by: Sascha Wilde -;; Created: 1999/10/28 -;; Keywords: PGP - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see . - -;;; Commentary: - -;; This file is on its way to obsolescence, waiting for allout.el to -;; switch to EPG. - -;;; Code: - -(require 'pgg-def) -(require 'pgg-parse) -(autoload 'run-at-time "timer") - -;; Don't merge these two `eval-when-compile's. -(eval-when-compile - ;; For Emacs <22.2 and XEmacs. - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))) - (require 'cl)) - -;;; @ utility functions -;;; - -(eval-when-compile - (when (featurep 'xemacs) - (defmacro pgg-run-at-time-1 (time repeat function args) - (if (condition-case nil - (let ((delete-itimer 'delete-itimer) - (itimer-driver-start 'itimer-driver-start) - (itimer-value 'itimer-value) - (start-itimer 'start-itimer)) - (unless (or (symbol-value 'itimer-process) - (symbol-value 'itimer-timer)) - (funcall itimer-driver-start)) - ;; Check whether there is a bug to which the difference of - ;; the present time and the time when the itimer driver was - ;; woken up is subtracted from the initial itimer value. - (let* ((inhibit-quit t) - (ctime (current-time)) - (itimer-timer-last-wakeup - (prog1 - ctime - (setcar ctime (1- (car ctime))))) - (itimer-list nil) - (itimer (funcall start-itimer "pgg-run-at-time" - 'ignore 5))) - (sleep-for 0.1) ;; Accept the timeout interrupt. - (prog1 - (> (funcall itimer-value itimer) 0) - (funcall delete-itimer itimer)))) - (error nil)) - `(let ((time ,time)) - (apply #'start-itimer "pgg-run-at-time" - ,function (if time (max time 1e-9) 1e-9) - ,repeat nil t ,args)) - `(let ((time ,time) - (itimers (list nil))) - (setcar - itimers - (apply #'start-itimer "pgg-run-at-time" - (lambda (itimers repeat function &rest args) - (let ((itimer (car itimers))) - (if repeat - (progn - (set-itimer-function - itimer - (lambda (itimer repeat function &rest args) - (set-itimer-restart itimer repeat) - (set-itimer-function itimer function) - (set-itimer-function-arguments itimer args) - (apply function args))) - (set-itimer-function-arguments - itimer - (append (list itimer repeat function) args))) - (set-itimer-function - itimer - (lambda (itimer function &rest args) - (delete-itimer itimer) - (apply function args))) - (set-itimer-function-arguments - itimer - (append (list itimer function) args))))) - 1e-9 (if time (max time 1e-9) 1e-9) - nil t itimers ,repeat ,function ,args))))))) - -(eval-and-compile - (if (featurep 'xemacs) - (progn - (defun pgg-run-at-time (time repeat function &rest args) - "Emulating function run as `run-at-time'. -TIME should be nil meaning now, or a number of seconds from now. -Return an itimer object which can be used in either `delete-itimer' -or `cancel-timer'." - (pgg-run-at-time-1 time repeat function args)) - (defun pgg-cancel-timer (timer) - "Emulate cancel-timer for xemacs." - (let ((delete-itimer 'delete-itimer)) - (funcall delete-itimer timer)))) - (defalias 'pgg-run-at-time 'run-at-time) - (defalias 'pgg-cancel-timer 'cancel-timer))) - -(defun pgg-invoke (func scheme &rest args) - (progn - (require (intern (format "pgg-%s" scheme))) - (apply 'funcall (intern (format "pgg-%s-%s" scheme func)) args))) - -(put 'pgg-save-coding-system 'lisp-indent-function 2) - -(defmacro pgg-save-coding-system (start end &rest body) - `(if (called-interactively-p 'interactive) - (let ((buffer (current-buffer))) - (with-temp-buffer - (let (buffer-undo-list) - (insert-buffer-substring buffer ,start ,end) - (encode-coding-region (point-min)(point-max) - buffer-file-coding-system) - (prog1 (save-excursion ,@body) - (push nil buffer-undo-list) - (ignore-errors (undo)))))) - (save-restriction - (narrow-to-region ,start ,end) - ,@body))) - -(defun pgg-temp-buffer-show-function (buffer) - (let ((window (or (get-buffer-window buffer 'visible) - (split-window-vertically)))) - (set-window-buffer window buffer) - (shrink-window-if-larger-than-buffer window))) - -;; XXX `pgg-display-output-buffer' is a horrible name for this function. -;; It should be something like `pgg-situate-output-or-display-error'. -(defun pgg-display-output-buffer (start end status) - "Situate en/decryption results or pop up an error buffer. - -Text from START to END is replaced by contents of output buffer if STATUS -is true, or else the output buffer is displayed." - (if status - (pgg-situate-output start end) - (pgg-display-error-buffer))) - -(defun pgg-situate-output (start end) - "Place en/decryption result in place of current text from START to END." - (delete-region start end) - (insert-buffer-substring pgg-output-buffer) - (decode-coding-region start (point) buffer-file-coding-system)) - -(defun pgg-display-error-buffer () - "Pop up an error buffer indicating the reason for an en/decryption failure." - (let ((temp-buffer-show-function - (function pgg-temp-buffer-show-function))) - (with-output-to-temp-buffer pgg-echo-buffer - (set-buffer standard-output) - (insert-buffer-substring pgg-errors-buffer)))) - -(defvar pgg-passphrase-cache (make-vector 7 0)) - -(defvar pgg-pending-timers (make-vector 7 0) - "Hash table for managing scheduled pgg cache management timers. - -We associate key and timer, so the timer can be cancelled if a new -timeout for the key is set while an old one is still pending.") - -(defun pgg-read-passphrase (prompt &optional key notruncate) - "Using PROMPT, obtain passphrase for KEY from cache or user. - -Truncate the key to 8 trailing characters unless NOTRUNCATE is true -\(default false). - -Custom variables `pgg-cache-passphrase' and `pgg-passphrase-cache-expiry' -regulate cache behavior." - (or (pgg-read-passphrase-from-cache key notruncate) - (read-passwd prompt))) - -(defun pgg-read-passphrase-from-cache (key &optional notruncate) - "Obtain passphrase for KEY from time-limited passphrase cache. - -Truncate the key to 8 trailing characters unless NOTRUNCATE is true -\(default false). - -Custom variables `pgg-cache-passphrase' and `pgg-passphrase-cache-expiry' -regulate cache behavior." - (and pgg-cache-passphrase - key (or notruncate - (setq key (pgg-truncate-key-identifier key))) - (symbol-value (intern-soft key pgg-passphrase-cache)))) - -(defun pgg-add-passphrase-to-cache (key passphrase &optional notruncate) - "Associate KEY with PASSPHRASE in time-limited passphrase cache. - -Truncate the key to 8 trailing characters unless NOTRUNCATE is true -\(default false). - -Custom variables `pgg-cache-passphrase' and `pgg-passphrase-cache-expiry' -regulate cache behavior." - - (let* ((key (if notruncate key (pgg-truncate-key-identifier key))) - (interned-timer-key (intern-soft key pgg-pending-timers)) - (old-timer (symbol-value interned-timer-key)) - new-timer) - (when old-timer - (cancel-timer old-timer) - (unintern interned-timer-key pgg-pending-timers)) - (set (intern key pgg-passphrase-cache) - passphrase) - (set (intern key pgg-pending-timers) - (pgg-run-at-time pgg-passphrase-cache-expiry nil - #'pgg-remove-passphrase-from-cache - key notruncate)))) - -(if (fboundp 'clear-string) - (defalias 'pgg-clear-string 'clear-string) - (defun pgg-clear-string (string) - (fillarray string ?_))) - -(declare-function pgg-clear-string "pgg" (string)) - -(defun pgg-remove-passphrase-from-cache (key &optional notruncate) - "Omit passphrase associated with KEY in time-limited passphrase cache. - -Truncate the key to 8 trailing characters unless NOTRUNCATE is true -\(default false). - -This is a no-op if there is not entry for KEY (eg, it's already expired. - -The memory for the passphrase is filled with underscores to clear any -references to it. - -Custom variables `pgg-cache-passphrase' and `pgg-passphrase-cache-expiry' -regulate cache behavior." - (let* ((passphrase (pgg-read-passphrase-from-cache key notruncate)) - (key (if notruncate key (pgg-truncate-key-identifier key))) - (interned-timer-key (intern-soft key pgg-pending-timers)) - (old-timer (symbol-value interned-timer-key))) - (when passphrase - (pgg-clear-string passphrase) - (unintern key pgg-passphrase-cache)) - (when old-timer - (pgg-cancel-timer old-timer) - (unintern interned-timer-key pgg-pending-timers)))) - -(defmacro pgg-convert-lbt-region (start end lbt) - `(let ((pgg-conversion-end (set-marker (make-marker) ,end))) - (goto-char ,start) - (case ,lbt - (CRLF - (while (progn - (end-of-line) - (> (marker-position pgg-conversion-end) (point))) - (insert "\r") - (forward-line 1))) - (LF - (while (re-search-forward "\r$" pgg-conversion-end t) - (replace-match "")))))) - -(put 'pgg-as-lbt 'lisp-indent-function 3) - -(defmacro pgg-as-lbt (start end lbt &rest body) - `(let ((inhibit-read-only t) - buffer-read-only - buffer-undo-list) - (pgg-convert-lbt-region ,start ,end ,lbt) - (let ((,end (point))) - ,@body) - (push nil buffer-undo-list) - (ignore-errors (undo)))) - -(put 'pgg-process-when-success 'lisp-indent-function 0) - -(defmacro pgg-process-when-success (&rest body) - `(with-current-buffer pgg-output-buffer - (if (zerop (buffer-size)) nil ,@body t))) - -(defalias 'pgg-make-temp-file - (if (fboundp 'make-temp-file) - 'make-temp-file - (lambda (prefix &optional dir-flag) - (let ((file (expand-file-name - (make-temp-name prefix) - (if (fboundp 'temp-directory) - (temp-directory) - temporary-file-directory)))) - (if dir-flag - (make-directory file)) - file)))) - -;;; @ interface functions -;;; - -;;;###autoload -(defun pgg-encrypt-region (start end rcpts &optional sign passphrase) - "Encrypt the current region between START and END for RCPTS. - -If optional argument SIGN is non-nil, do a combined sign and encrypt. - -If optional PASSPHRASE is not specified, it will be obtained from the -passphrase cache or user." - (interactive - (list (region-beginning)(region-end) - (split-string (read-string "Recipients: ") "[ \t,]+"))) - (let ((status - (pgg-save-coding-system start end - (pgg-invoke "encrypt-region" (or pgg-scheme pgg-default-scheme) - (point-min) (point-max) rcpts sign passphrase)))) - (when (called-interactively-p 'interactive) - (pgg-display-output-buffer start end status)) - status)) - -;;;###autoload -(defun pgg-encrypt-symmetric-region (start end &optional passphrase) - "Encrypt the current region between START and END symmetric with passphrase. - -If optional PASSPHRASE is not specified, it will be obtained from the -cache or user." - (interactive "r") - (let ((status - (pgg-save-coding-system start end - (pgg-invoke "encrypt-symmetric-region" - (or pgg-scheme pgg-default-scheme) - (point-min) (point-max) passphrase)))) - (when (called-interactively-p 'interactive) - (pgg-display-output-buffer start end status)) - status)) - -;;;###autoload -(defun pgg-encrypt-symmetric (&optional start end passphrase) - "Encrypt the current buffer using a symmetric, rather than key-pair, cipher. - -If optional arguments START and END are specified, only encrypt within -the region. - -If optional PASSPHRASE is not specified, it will be obtained from the -passphrase cache or user." - (interactive) - (let* ((start (or start (point-min))) - (end (or end (point-max))) - (status (pgg-encrypt-symmetric-region start end passphrase))) - (when (called-interactively-p 'interactive) - (pgg-display-output-buffer start end status)) - status)) - -;;;###autoload -(defun pgg-encrypt (rcpts &optional sign start end passphrase) - "Encrypt the current buffer for RCPTS. - -If optional argument SIGN is non-nil, do a combined sign and encrypt. - -If optional arguments START and END are specified, only encrypt within -the region. - -If optional PASSPHRASE is not specified, it will be obtained from the -passphrase cache or user." - (interactive (list (split-string (read-string "Recipients: ") "[ \t,]+"))) - (let* ((start (or start (point-min))) - (end (or end (point-max))) - (status (pgg-encrypt-region start end rcpts sign passphrase))) - (when (called-interactively-p 'interactive) - (pgg-display-output-buffer start end status)) - status)) - -;;;###autoload -(defun pgg-decrypt-region (start end &optional passphrase) - "Decrypt the current region between START and END. - -If optional PASSPHRASE is not specified, it will be obtained from the -passphrase cache or user." - (interactive "r") - (let* ((buf (current-buffer)) - (status - (pgg-save-coding-system start end - (pgg-invoke "decrypt-region" (or pgg-scheme pgg-default-scheme) - (point-min) (point-max) passphrase)))) - (when (called-interactively-p 'interactive) - (pgg-display-output-buffer start end status)) - status)) - -;;;###autoload -(defun pgg-decrypt (&optional start end passphrase) - "Decrypt the current buffer. - -If optional arguments START and END are specified, only decrypt within -the region. - -If optional PASSPHRASE is not specified, it will be obtained from the -passphrase cache or user." - (interactive "") - (let* ((start (or start (point-min))) - (end (or end (point-max))) - (status (pgg-decrypt-region start end passphrase))) - (when (called-interactively-p 'interactive) - (pgg-display-output-buffer start end status)) - status)) - -;;;###autoload -(defun pgg-sign-region (start end &optional cleartext passphrase) - "Make the signature from text between START and END. - -If the optional 3rd argument CLEARTEXT is non-nil, it does not create -a detached signature. - -If this function is called interactively, CLEARTEXT is enabled -and the output is displayed. - -If optional PASSPHRASE is not specified, it will be obtained from the -passphrase cache or user." - (interactive "r") - (let ((status (pgg-save-coding-system start end - (pgg-invoke "sign-region" (or pgg-scheme pgg-default-scheme) - (point-min) (point-max) - (or (called-interactively-p 'interactive) - cleartext) - passphrase)))) - (when (called-interactively-p 'interactive) - (pgg-display-output-buffer start end status)) - status)) - -;;;###autoload -(defun pgg-sign (&optional cleartext start end passphrase) - "Sign the current buffer. - -If the optional argument CLEARTEXT is non-nil, it does not create a -detached signature. - -If optional arguments START and END are specified, only sign data -within the region. - -If this function is called interactively, CLEARTEXT is enabled -and the output is displayed. - -If optional PASSPHRASE is not specified, it will be obtained from the -passphrase cache or user." - (interactive "") - (let* ((start (or start (point-min))) - (end (or end (point-max))) - (status (pgg-sign-region start end - (or (called-interactively-p 'interactive) - cleartext) - passphrase))) - (when (called-interactively-p 'interactive) - (pgg-display-output-buffer start end status)) - status)) - -;;;###autoload -(defun pgg-verify-region (start end &optional signature fetch) - "Verify the current region between START and END. -If the optional 3rd argument SIGNATURE is non-nil, it is treated as -the detached signature of the current region. - -If the optional 4th argument FETCH is non-nil, we attempt to fetch the -signer's public key from `pgg-default-keyserver-address'." - (interactive "r") - (let* ((packet - (if (null signature) nil - (with-temp-buffer - (buffer-disable-undo) - (unless (featurep 'xemacs) - (set-buffer-multibyte nil)) - (insert-file-contents signature) - (cdr (assq 2 (pgg-decode-armor-region - (point-min)(point-max))))))) - (key (cdr (assq 'key-identifier packet))) - status keyserver) - (and (stringp key) - pgg-query-keyserver - (setq key (concat "0x" (pgg-truncate-key-identifier key))) - (null (pgg-lookup-key key)) - (or fetch (called-interactively-p 'interactive)) - (y-or-n-p (format "Key %s not found; attempt to fetch? " key)) - (setq keyserver - (or (cdr (assq 'preferred-key-server packet)) - pgg-default-keyserver-address)) - (pgg-fetch-key keyserver key)) - (setq status - (pgg-save-coding-system start end - (pgg-invoke "verify-region" (or pgg-scheme pgg-default-scheme) - (point-min) (point-max) signature))) - (when (called-interactively-p 'interactive) - (let ((temp-buffer-show-function - (function pgg-temp-buffer-show-function))) - (with-output-to-temp-buffer pgg-echo-buffer - (set-buffer standard-output) - (insert-buffer-substring (if status pgg-output-buffer - pgg-errors-buffer))))) - status)) - -;;;###autoload -(defun pgg-verify (&optional signature fetch start end) - "Verify the current buffer. -If the optional argument SIGNATURE is non-nil, it is treated as -the detached signature of the current region. -If the optional argument FETCH is non-nil, we attempt to fetch the -signer's public key from `pgg-default-keyserver-address'. -If optional arguments START and END are specified, only verify data -within the region." - (interactive "") - (let* ((start (or start (point-min))) - (end (or end (point-max))) - (status (pgg-verify-region start end signature fetch))) - (when (called-interactively-p 'interactive) - (let ((temp-buffer-show-function - (function pgg-temp-buffer-show-function))) - (with-output-to-temp-buffer pgg-echo-buffer - (set-buffer standard-output) - (insert-buffer-substring (if status pgg-output-buffer - pgg-errors-buffer))))) - status)) - -;;;###autoload -(defun pgg-insert-key () - "Insert the ASCII armored public key." - (interactive) - (pgg-invoke "insert-key" (or pgg-scheme pgg-default-scheme))) - -;;;###autoload -(defun pgg-snarf-keys-region (start end) - "Import public keys in the current region between START and END." - (interactive "r") - (pgg-save-coding-system start end - (pgg-invoke "snarf-keys-region" (or pgg-scheme pgg-default-scheme) - start end))) - -;;;###autoload -(defun pgg-snarf-keys () - "Import public keys in the current buffer." - (interactive "") - (pgg-snarf-keys-region (point-min) (point-max))) - -(defun pgg-lookup-key (string &optional type) - (pgg-invoke "lookup-key" (or pgg-scheme pgg-default-scheme) string type)) - -(defvar pgg-insert-url-function (function pgg-insert-url-with-w3)) - -(defun pgg-insert-url-with-w3 (url) - (ignore-errors - (require 'url) - (let (buffer-file-name) - (url-insert-file-contents url)))) - -(defvar pgg-insert-url-extra-arguments nil) -(defvar pgg-insert-url-program nil) - -(defun pgg-insert-url-with-program (url) - (let ((args (copy-sequence pgg-insert-url-extra-arguments)) - process) - (insert - (with-temp-buffer - (setq process - (apply #'start-process " *PGG url*" (current-buffer) - pgg-insert-url-program (nconc args (list url)))) - (set-process-sentinel process #'ignore) - (while (eq 'run (process-status process)) - (accept-process-output process 5)) - (delete-process process) - (if (and process (eq 'run (process-status process))) - (interrupt-process process)) - (buffer-string))))) - -(defun pgg-fetch-key (keyserver key) - "Attempt to fetch a KEY from KEYSERVER for addition to PGP or GnuPG keyring." - (with-current-buffer (get-buffer-create pgg-output-buffer) - (buffer-disable-undo) - (erase-buffer) - (let ((proto (if (string-match "^[a-zA-Z\\+\\.\\\\-]+:" keyserver) - (substring keyserver 0 (1- (match-end 0)))))) - (save-excursion - (funcall pgg-insert-url-function - (if proto keyserver - (format "http://%s:11371/pks/lookup?op=get&search=%s" - keyserver key)))) - (when (re-search-forward "^-+BEGIN" nil 'last) - (delete-region (point-min) (match-beginning 0)) - (when (re-search-forward "^-+END" nil t) - (delete-region (progn (end-of-line) (point)) - (point-max))) - (insert "\n") - (with-temp-buffer - (insert-buffer-substring pgg-output-buffer) - (pgg-snarf-keys-region (point-min)(point-max))))))) - - -(provide 'pgg) - -;;; pgg.el ends here