Mercurial > emacs
changeset 66383:c82982d6cbc4
Moved pgg*.el files from lisp/gnus to lisp.
| author | Eli Zaretskii <eliz@gnu.org> |
|---|---|
| date | Mon, 24 Oct 2005 09:46:27 +0000 |
| parents | 9e9e3aac0fda |
| children | 98575511e3ad |
| files | lisp/gnus/pgg-def.el lisp/gnus/pgg-gpg.el lisp/gnus/pgg-parse.el lisp/gnus/pgg-pgp.el lisp/gnus/pgg-pgp5.el lisp/gnus/pgg.el lisp/pgg-def.el lisp/pgg-gpg.el lisp/pgg-parse.el lisp/pgg-pgp.el lisp/pgg-pgp5.el lisp/pgg.el |
| diffstat | 12 files changed, 1829 insertions(+), 1829 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/gnus/pgg-def.el Mon Oct 24 08:54:18 2005 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,91 +0,0 @@ -;;; pgg-def.el --- functions/macros for defining PGG functions - -;; Copyright (C) 1999, 2002, 2003, 2004, 2005 Free Software Foundation, Inc. - -;; Author: Daiki Ueno <ueno@unixuser.org> -;; Created: 1999/11/02 -;; Keywords: PGP, OpenPGP, GnuPG - -;; 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; 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) - -(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.") - -(defmacro pgg-truncate-key-identifier (key) - `(if (> (length ,key) 8) (substring ,key 8) ,key)) - -(provide 'pgg-def) - -;;; arch-tag: c425f3ab-ed75-4055-bb46-431a418c94b7 -;;; pgg-def.el ends here
--- a/lisp/gnus/pgg-gpg.el Mon Oct 24 08:54:18 2005 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,275 +0,0 @@ -;;; pgg-gpg.el --- GnuPG support for PGG. - -;; Copyright (C) 1999, 2000, 2002, 2003, 2004, -;; 2005 Free Software Foundation, Inc. - -;; Author: Daiki Ueno <ueno@unixuser.org> -;; Created: 1999/10/28 -;; Keywords: PGP, OpenPGP, GnuPG - -;; 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; 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"))) - -(defvar pgg-gpg-user-id nil - "GnuPG ID of your default identity.") - -(defun pgg-gpg-process-region (start end passphrase program args) - (let* ((output-file-name (pgg-make-temp-file "pgg-output")) - (args - `("--status-fd" "2" - ,@(if passphrase '("--passphrase-fd" "0")) - "--yes" ; overwrite - "--output" ,output-file-name - ,@pgg-gpg-extra-args ,@args)) - (output-buffer pgg-output-buffer) - (errors-buffer pgg-errors-buffer) - (orig-mode (default-file-modes)) - (process-connection-type nil) - exit-status) - (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) - (input (buffer-substring-no-properties start end)) - (default-enable-multibyte-characters nil)) - (with-temp-buffer - (when passphrase - (insert passphrase "\n")) - (insert input) - (setq exit-status - (apply #'call-process-region (point-min) (point-max) program - nil errors-buffer nil args)))) - (with-current-buffer (get-buffer-create output-buffer) - (buffer-disable-undo) - (erase-buffer) - (if (file-exists-p output-file-name) - (let ((coding-system-for-read 'raw-text-dos)) - (insert-file-contents output-file-name))) - (set-buffer errors-buffer) - (if (not (equal exit-status 0)) - (insert (format "\n%s exited abnormally: '%s'\n" - program exit-status))))) - (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) - (if (and pgg-cache-passphrase - (progn - (goto-char (point-min)) - (re-search-forward "^\\[GNUPG:] \\(GOOD_PASSPHRASE\\>\\)\\|\\(SIG_CREATED\\)" nil t))) - (pgg-add-passphrase-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))) - -(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-encrypt-region (start end recipients &optional sign) - "Encrypt the current region between START and END. -If optional argument SIGN is non-nil, do a combined sign and encrypt." - (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id)) - (passphrase - (when sign - (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 sign (list "--sign" "--local-user" pgg-gpg-user-id)) - (if recipients - (apply #'nconc - (mapcar (lambda (rcpt) - (list pgg-gpg-recipient-argument rcpt)) - (append recipients - (if pgg-encrypt-for-me - (list pgg-gpg-user-id))))))))) - (pgg-as-lbt start end 'CRLF - (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-decrypt-region (start end) - "Decrypt the current region between START and END." - (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)) - (key (pgg-gpg-select-matching-key message-keys secret-keys)) - (pgg-gpg-user-id (or key pgg-gpg-user-id pgg-default-user-id)) - (passphrase - (pgg-read-passphrase - (format "GnuPG passphrase for %s: " pgg-gpg-user-id) - 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)))) - -(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 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) - "Make detached signature from text between START and END." - (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id)) - (passphrase - (pgg-read-passphrase - (format "GnuPG passphrase for %s: " pgg-gpg-user-id) - pgg-gpg-user-id)) - (args - (list (if cleartext "--clearsign" "--detach-sign") - "--armor" "--batch" "--verbose" - "--local-user" pgg-gpg-user-id)) - (inhibit-read-only t) - buffer-read-only) - (pgg-as-lbt start end 'CRLF - (pgg-gpg-process-region start end passphrase pgg-gpg-program args)) - (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))) - -(provide 'pgg-gpg) - -;;; arch-tag: 2aa5d5d8-93a0-4865-9312-33e29830e000 -;;; pgg-gpg.el ends here
--- a/lisp/gnus/pgg-parse.el Mon Oct 24 08:54:18 2005 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,515 +0,0 @@ -;;; pgg-parse.el --- OpenPGP packet parsing - -;; Copyright (C) 1999, 2002, 2003, 2004, 2005 Free Software Foundation, Inc. - -;; Author: Daiki Ueno <ueno@unixuser.org> -;; Created: 1999/10/28 -;; Keywords: PGP, OpenPGP, GnuPG - -;; 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;; This module is based on - -;; [OpenPGP] RFC 2440: "OpenPGP Message Format" -;; by John W. Noerenberg, II <jwn2@qualcomm.com>, -;; Jon Callas <jon@pgp.com>, Lutz Donnerhacke <lutz@iks-jena.de>, -;; Hal Finney <hal@pgp.com> and Rodney Thayer <rodney@unitran.com> -;; (1998/11) - -;;; Code: - -(eval-when-compile (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))))) - - (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)) - -(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) - (if (fboundp 'set-buffer-multibyte) - (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) - -;;; arch-tag: 16c2eb82-1313-4a7c-a70f-420709b5b43e -;;; pgg-parse.el ends here
--- a/lisp/gnus/pgg-pgp.el Mon Oct 24 08:54:18 2005 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,245 +0,0 @@ -;;; pgg-pgp.el --- PGP 2.* and 6.* support for PGG. - -;; Copyright (C) 1999, 2000, 2002, 2003, 2004, -;; 2005 Free Software Foundation, Inc. - -;; Author: Daiki Ueno <ueno@unixuser.org> -;; Created: 1999/11/02 -;; Keywords: PGP, OpenPGP - -;; 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; 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 - (append args - pgg-pgp-extra-args - (list (concat "2>" 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 - (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-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) - "Encrypt the current region between START and END." - (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id)) - (args - `("+encrypttoself=off +verbose=1" "+batchmode" - "+language=us" "-fate" - ,@(if recipients - (mapcar (lambda (rcpt) (concat "\"" rcpt "\"")) - (append recipients - (if pgg-encrypt-for-me - (list 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) - "Decrypt the current region between START and END." - (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 - (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-cache key passphrase))))) - -(defun pgg-pgp-sign-region (start end &optional clearsign) - "Make detached signature from text between START and END." - (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id)) - (passphrase - (pgg-read-passphrase - (format "PGP passphrase for %s: " pgg-pgp-user-id) - (pgg-pgp-lookup-key pgg-pgp-user-id 'sign))) - (args - (list (if clearsign "-fast" "-fbast") - "+verbose=1" "+language=us" "+batchmode" - "-u" 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-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 (append args (list signature orig-file)))) - (setq args (append args (list 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 - (list "+verbose=1" "+batchmode" "+language=us" "-kxaf" - (concat "\"" 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 - (list "+verbose=1" "+batchmode" "+language=us" "-kaf" - 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) - -;;; arch-tag: 076b7801-37b2-49a6-97c3-218fdecde33c -;;; pgg-pgp.el ends here
--- a/lisp/gnus/pgg-pgp5.el Mon Oct 24 08:54:18 2005 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,250 +0,0 @@ -;;; pgg-pgp5.el --- PGP 5.* support for PGG. - -;; Copyright (C) 1999, 2000, 2002, 2003, 2004, -;; 2005 Free Software Foundation, Inc. - -;; Author: Daiki Ueno <ueno@unixuser.org> -;; Created: 1999/11/02 -;; Keywords: PGP, OpenPGP - -;; 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; 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) - "Encrypt the current region between START and END." - (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) - (args - `("+NoBatchInvalidKeys=off" "-fat" "+batchmode=1" - ,@(if recipients - (apply #'append - (mapcar (lambda (rcpt) - (list "-r" - (concat "\"" rcpt "\""))) - (append recipients - (if pgg-encrypt-for-me - (list 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) - "Decrypt the current region between START and END." - (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) - (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) - "Make detached signature from text between START and END." - (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) - (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-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) - -;;; arch-tag: 3dbd1073-6b3a-466c-9f55-5c587ffa6d7b -;;; pgg-pgp5.el ends here
--- a/lisp/gnus/pgg.el Mon Oct 24 08:54:18 2005 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,453 +0,0 @@ -;;; pgg.el --- glue for the various PGP implementations. - -;; Copyright (C) 1999, 2000, 2002, 2003, 2004, -;; 2005 Free Software Foundation, Inc. - -;; Author: Daiki Ueno <ueno@unixuser.org> -;; 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 2, 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; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;;; Code: - -(require 'pgg-def) -(require 'pgg-parse) -(autoload 'run-at-time "timer") - -;; Don't merge these two `eval-when-compile's. -(eval-when-compile - (require 'cl)) - -;;; @ utility functions -;;; - -(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 (interactive-p) - (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))) - -(defun pgg-display-output-buffer (start end status) - (if status - (progn - (delete-region start end) - (insert-buffer-substring pgg-output-buffer) - (decode-coding-region start (point) buffer-file-coding-system)) - (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)) - -(defun pgg-read-passphrase (prompt &optional key) - (or (and pgg-cache-passphrase - key (setq key (pgg-truncate-key-identifier key)) - (symbol-value (intern-soft key pgg-passphrase-cache))) - (read-passwd prompt))) - -(eval-when-compile - (defmacro pgg-run-at-time-1 (time repeat function args) - (when (featurep 'xemacs) - (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) - (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)) - (defalias 'pgg-run-at-time 'run-at-time))) - -(defun pgg-add-passphrase-cache (key passphrase) - (setq key (pgg-truncate-key-identifier key)) - (set (intern key pgg-passphrase-cache) - passphrase) - (pgg-run-at-time pgg-passphrase-cache-expiry nil - #'pgg-remove-passphrase-cache - key)) - -(defun pgg-remove-passphrase-cache (key) - (let ((passphrase (symbol-value (intern-soft key pgg-passphrase-cache)))) - (when passphrase - (fillarray passphrase ?_) - (unintern key pgg-passphrase-cache)))) - -(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) - "Encrypt the current region between START and END for RCPTS. -If optional argument SIGN is non-nil, do a combined sign and encrypt." - (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)))) - (when (interactive-p) - (pgg-display-output-buffer start end status)) - status)) - -;;;###autoload -(defun pgg-encrypt (rcpts &optional sign start end) - "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." - (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))) - (when (interactive-p) - (pgg-display-output-buffer start end status)) - status)) - -;;;###autoload -(defun pgg-decrypt-region (start end) - "Decrypt the current region between START and END." - (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))))) - (when (interactive-p) - (pgg-display-output-buffer start end status)) - status)) - -;;;###autoload -(defun pgg-decrypt (&optional start end) - "Decrypt the current buffer. -If optional arguments START and END are specified, only decrypt within -the region." - (interactive "") - (let* ((start (or start (point-min))) - (end (or end (point-max))) - (status (pgg-decrypt-region start end))) - (when (interactive-p) - (pgg-display-output-buffer start end status)) - status)) - -;;;###autoload -(defun pgg-sign-region (start end &optional cleartext) - "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 the output is displayed." - (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 (interactive-p) cleartext))))) - (when (interactive-p) - (pgg-display-output-buffer start end status)) - status)) - -;;;###autoload -(defun pgg-sign (&optional cleartext start end) - "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 the output is displayed." - (interactive "") - (let* ((start (or start (point-min))) - (end (or end (point-max))) - (status (pgg-sign-region start end (or (interactive-p) cleartext)))) - (when (interactive-p) - (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) - (if (fboundp 'set-buffer-multibyte) - (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 (interactive-p)) - (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 (interactive-p) - (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 (interactive-p) - (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) - -;;; arch-tag: 9cc705dd-1e6a-4c90-8dce-c3561f9a2cf4 -;;; pgg.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/pgg-def.el Mon Oct 24 09:46:27 2005 +0000 @@ -0,0 +1,91 @@ +;;; pgg-def.el --- functions/macros for defining PGG functions + +;; Copyright (C) 1999, 2002, 2003, 2004, 2005 Free Software Foundation, Inc. + +;; Author: Daiki Ueno <ueno@unixuser.org> +;; Created: 1999/11/02 +;; Keywords: PGP, OpenPGP, GnuPG + +;; 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 2, 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; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; 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) + +(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.") + +(defmacro pgg-truncate-key-identifier (key) + `(if (> (length ,key) 8) (substring ,key 8) ,key)) + +(provide 'pgg-def) + +;;; arch-tag: c425f3ab-ed75-4055-bb46-431a418c94b7 +;;; pgg-def.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/pgg-gpg.el Mon Oct 24 09:46:27 2005 +0000 @@ -0,0 +1,275 @@ +;;; pgg-gpg.el --- GnuPG support for PGG. + +;; Copyright (C) 1999, 2000, 2002, 2003, 2004, +;; 2005 Free Software Foundation, Inc. + +;; Author: Daiki Ueno <ueno@unixuser.org> +;; Created: 1999/10/28 +;; Keywords: PGP, OpenPGP, GnuPG + +;; 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 2, 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; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; 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"))) + +(defvar pgg-gpg-user-id nil + "GnuPG ID of your default identity.") + +(defun pgg-gpg-process-region (start end passphrase program args) + (let* ((output-file-name (pgg-make-temp-file "pgg-output")) + (args + `("--status-fd" "2" + ,@(if passphrase '("--passphrase-fd" "0")) + "--yes" ; overwrite + "--output" ,output-file-name + ,@pgg-gpg-extra-args ,@args)) + (output-buffer pgg-output-buffer) + (errors-buffer pgg-errors-buffer) + (orig-mode (default-file-modes)) + (process-connection-type nil) + exit-status) + (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) + (input (buffer-substring-no-properties start end)) + (default-enable-multibyte-characters nil)) + (with-temp-buffer + (when passphrase + (insert passphrase "\n")) + (insert input) + (setq exit-status + (apply #'call-process-region (point-min) (point-max) program + nil errors-buffer nil args)))) + (with-current-buffer (get-buffer-create output-buffer) + (buffer-disable-undo) + (erase-buffer) + (if (file-exists-p output-file-name) + (let ((coding-system-for-read 'raw-text-dos)) + (insert-file-contents output-file-name))) + (set-buffer errors-buffer) + (if (not (equal exit-status 0)) + (insert (format "\n%s exited abnormally: '%s'\n" + program exit-status))))) + (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) + (if (and pgg-cache-passphrase + (progn + (goto-char (point-min)) + (re-search-forward "^\\[GNUPG:] \\(GOOD_PASSPHRASE\\>\\)\\|\\(SIG_CREATED\\)" nil t))) + (pgg-add-passphrase-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))) + +(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-encrypt-region (start end recipients &optional sign) + "Encrypt the current region between START and END. +If optional argument SIGN is non-nil, do a combined sign and encrypt." + (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id)) + (passphrase + (when sign + (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 sign (list "--sign" "--local-user" pgg-gpg-user-id)) + (if recipients + (apply #'nconc + (mapcar (lambda (rcpt) + (list pgg-gpg-recipient-argument rcpt)) + (append recipients + (if pgg-encrypt-for-me + (list pgg-gpg-user-id))))))))) + (pgg-as-lbt start end 'CRLF + (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-decrypt-region (start end) + "Decrypt the current region between START and END." + (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)) + (key (pgg-gpg-select-matching-key message-keys secret-keys)) + (pgg-gpg-user-id (or key pgg-gpg-user-id pgg-default-user-id)) + (passphrase + (pgg-read-passphrase + (format "GnuPG passphrase for %s: " pgg-gpg-user-id) + 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)))) + +(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 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) + "Make detached signature from text between START and END." + (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id)) + (passphrase + (pgg-read-passphrase + (format "GnuPG passphrase for %s: " pgg-gpg-user-id) + pgg-gpg-user-id)) + (args + (list (if cleartext "--clearsign" "--detach-sign") + "--armor" "--batch" "--verbose" + "--local-user" pgg-gpg-user-id)) + (inhibit-read-only t) + buffer-read-only) + (pgg-as-lbt start end 'CRLF + (pgg-gpg-process-region start end passphrase pgg-gpg-program args)) + (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))) + +(provide 'pgg-gpg) + +;;; arch-tag: 2aa5d5d8-93a0-4865-9312-33e29830e000 +;;; pgg-gpg.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/pgg-parse.el Mon Oct 24 09:46:27 2005 +0000 @@ -0,0 +1,515 @@ +;;; pgg-parse.el --- OpenPGP packet parsing + +;; Copyright (C) 1999, 2002, 2003, 2004, 2005 Free Software Foundation, Inc. + +;; Author: Daiki Ueno <ueno@unixuser.org> +;; Created: 1999/10/28 +;; Keywords: PGP, OpenPGP, GnuPG + +;; 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 2, 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; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; This module is based on + +;; [OpenPGP] RFC 2440: "OpenPGP Message Format" +;; by John W. Noerenberg, II <jwn2@qualcomm.com>, +;; Jon Callas <jon@pgp.com>, Lutz Donnerhacke <lutz@iks-jena.de>, +;; Hal Finney <hal@pgp.com> and Rodney Thayer <rodney@unitran.com> +;; (1998/11) + +;;; Code: + +(eval-when-compile (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))))) + + (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)) + +(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) + (if (fboundp 'set-buffer-multibyte) + (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) + +;;; arch-tag: 16c2eb82-1313-4a7c-a70f-420709b5b43e +;;; pgg-parse.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/pgg-pgp.el Mon Oct 24 09:46:27 2005 +0000 @@ -0,0 +1,245 @@ +;;; pgg-pgp.el --- PGP 2.* and 6.* support for PGG. + +;; Copyright (C) 1999, 2000, 2002, 2003, 2004, +;; 2005 Free Software Foundation, Inc. + +;; Author: Daiki Ueno <ueno@unixuser.org> +;; Created: 1999/11/02 +;; Keywords: PGP, OpenPGP + +;; 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 2, 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; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; 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 + (append args + pgg-pgp-extra-args + (list (concat "2>" 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 + (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-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) + "Encrypt the current region between START and END." + (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id)) + (args + `("+encrypttoself=off +verbose=1" "+batchmode" + "+language=us" "-fate" + ,@(if recipients + (mapcar (lambda (rcpt) (concat "\"" rcpt "\"")) + (append recipients + (if pgg-encrypt-for-me + (list 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) + "Decrypt the current region between START and END." + (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 + (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-cache key passphrase))))) + +(defun pgg-pgp-sign-region (start end &optional clearsign) + "Make detached signature from text between START and END." + (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id)) + (passphrase + (pgg-read-passphrase + (format "PGP passphrase for %s: " pgg-pgp-user-id) + (pgg-pgp-lookup-key pgg-pgp-user-id 'sign))) + (args + (list (if clearsign "-fast" "-fbast") + "+verbose=1" "+language=us" "+batchmode" + "-u" 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-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 (append args (list signature orig-file)))) + (setq args (append args (list 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 + (list "+verbose=1" "+batchmode" "+language=us" "-kxaf" + (concat "\"" 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 + (list "+verbose=1" "+batchmode" "+language=us" "-kaf" + 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) + +;;; arch-tag: 076b7801-37b2-49a6-97c3-218fdecde33c +;;; pgg-pgp.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/pgg-pgp5.el Mon Oct 24 09:46:27 2005 +0000 @@ -0,0 +1,250 @@ +;;; pgg-pgp5.el --- PGP 5.* support for PGG. + +;; Copyright (C) 1999, 2000, 2002, 2003, 2004, +;; 2005 Free Software Foundation, Inc. + +;; Author: Daiki Ueno <ueno@unixuser.org> +;; Created: 1999/11/02 +;; Keywords: PGP, OpenPGP + +;; 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 2, 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; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; 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) + "Encrypt the current region between START and END." + (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) + (args + `("+NoBatchInvalidKeys=off" "-fat" "+batchmode=1" + ,@(if recipients + (apply #'append + (mapcar (lambda (rcpt) + (list "-r" + (concat "\"" rcpt "\""))) + (append recipients + (if pgg-encrypt-for-me + (list 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) + "Decrypt the current region between START and END." + (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) + (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) + "Make detached signature from text between START and END." + (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) + (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-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) + +;;; arch-tag: 3dbd1073-6b3a-466c-9f55-5c587ffa6d7b +;;; pgg-pgp5.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/pgg.el Mon Oct 24 09:46:27 2005 +0000 @@ -0,0 +1,453 @@ +;;; pgg.el --- glue for the various PGP implementations. + +;; Copyright (C) 1999, 2000, 2002, 2003, 2004, +;; 2005 Free Software Foundation, Inc. + +;; Author: Daiki Ueno <ueno@unixuser.org> +;; 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 2, 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; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;;; Code: + +(require 'pgg-def) +(require 'pgg-parse) +(autoload 'run-at-time "timer") + +;; Don't merge these two `eval-when-compile's. +(eval-when-compile + (require 'cl)) + +;;; @ utility functions +;;; + +(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 (interactive-p) + (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))) + +(defun pgg-display-output-buffer (start end status) + (if status + (progn + (delete-region start end) + (insert-buffer-substring pgg-output-buffer) + (decode-coding-region start (point) buffer-file-coding-system)) + (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)) + +(defun pgg-read-passphrase (prompt &optional key) + (or (and pgg-cache-passphrase + key (setq key (pgg-truncate-key-identifier key)) + (symbol-value (intern-soft key pgg-passphrase-cache))) + (read-passwd prompt))) + +(eval-when-compile + (defmacro pgg-run-at-time-1 (time repeat function args) + (when (featurep 'xemacs) + (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) + (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)) + (defalias 'pgg-run-at-time 'run-at-time))) + +(defun pgg-add-passphrase-cache (key passphrase) + (setq key (pgg-truncate-key-identifier key)) + (set (intern key pgg-passphrase-cache) + passphrase) + (pgg-run-at-time pgg-passphrase-cache-expiry nil + #'pgg-remove-passphrase-cache + key)) + +(defun pgg-remove-passphrase-cache (key) + (let ((passphrase (symbol-value (intern-soft key pgg-passphrase-cache)))) + (when passphrase + (fillarray passphrase ?_) + (unintern key pgg-passphrase-cache)))) + +(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) + "Encrypt the current region between START and END for RCPTS. +If optional argument SIGN is non-nil, do a combined sign and encrypt." + (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)))) + (when (interactive-p) + (pgg-display-output-buffer start end status)) + status)) + +;;;###autoload +(defun pgg-encrypt (rcpts &optional sign start end) + "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." + (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))) + (when (interactive-p) + (pgg-display-output-buffer start end status)) + status)) + +;;;###autoload +(defun pgg-decrypt-region (start end) + "Decrypt the current region between START and END." + (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))))) + (when (interactive-p) + (pgg-display-output-buffer start end status)) + status)) + +;;;###autoload +(defun pgg-decrypt (&optional start end) + "Decrypt the current buffer. +If optional arguments START and END are specified, only decrypt within +the region." + (interactive "") + (let* ((start (or start (point-min))) + (end (or end (point-max))) + (status (pgg-decrypt-region start end))) + (when (interactive-p) + (pgg-display-output-buffer start end status)) + status)) + +;;;###autoload +(defun pgg-sign-region (start end &optional cleartext) + "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 the output is displayed." + (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 (interactive-p) cleartext))))) + (when (interactive-p) + (pgg-display-output-buffer start end status)) + status)) + +;;;###autoload +(defun pgg-sign (&optional cleartext start end) + "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 the output is displayed." + (interactive "") + (let* ((start (or start (point-min))) + (end (or end (point-max))) + (status (pgg-sign-region start end (or (interactive-p) cleartext)))) + (when (interactive-p) + (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) + (if (fboundp 'set-buffer-multibyte) + (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 (interactive-p)) + (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 (interactive-p) + (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 (interactive-p) + (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) + +;;; arch-tag: 9cc705dd-1e6a-4c90-8dce-c3561f9a2cf4 +;;; pgg.el ends here