+++ /dev/null
-;;; 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
-;;; 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
-;;; 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
-;;; 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
-;;; 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
-;;; 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
+;;; 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
+;;; 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
+;;; 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
+;;; 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
+;;; 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
+;;; 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
projects / emacs.git / commitdiff