diff options
Diffstat (limited to 'lisp/gnus')
| -rw-r--r-- | lisp/gnus/ChangeLog | 64 | ||||
| -rw-r--r-- | lisp/gnus/gnus-art.el | 9 | ||||
| -rw-r--r-- | lisp/gnus/gnus-score.el | 21 | ||||
| -rw-r--r-- | lisp/gnus/gnus-sum.el | 4 | ||||
| -rw-r--r-- | lisp/gnus/imap.el | 7 | ||||
| -rw-r--r-- | lisp/gnus/mail-source.el | 2 | ||||
| -rw-r--r-- | lisp/gnus/message.el | 3 | ||||
| -rw-r--r-- | lisp/gnus/nnslashdot.el | 53 | ||||
| -rw-r--r-- | lisp/gnus/pgg-def.el | 91 | ||||
| -rw-r--r-- | lisp/gnus/pgg-gpg.el | 275 | ||||
| -rw-r--r-- | lisp/gnus/pgg-parse.el | 515 | ||||
| -rw-r--r-- | lisp/gnus/pgg-pgp.el | 245 | ||||
| -rw-r--r-- | lisp/gnus/pgg-pgp5.el | 250 | ||||
| -rw-r--r-- | lisp/gnus/pgg.el | 453 | ||||
| -rw-r--r-- | lisp/gnus/rfc2047.el | 170 |
15 files changed, 219 insertions, 1943 deletions
diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index 04213b9fa45..d6d4d99a853 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -1,3 +1,67 @@ +2005-10-24 Eli Zaretskii <eliz@gnu.org> + + * pgg-def.el: + * pgg-gpg.el: + * pgg-parse.el: + * pgg-pgp.el: + * pgg-pgp5.el: + * pgg.el: Move to the parent lisp directory. + +2005-10-23 Chong Yidong <cyd@stupidchicken.com> + + * gnus-sum.el (gnus-ignored-from-addresses): Handle case where + user-mail-name is an empty string. + +2005-10-25 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-score.el (gnus-default-adaptive-score-alist): Set defaults + depending on gnus-score-decay-constant. + +2005-10-25 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * nnslashdot.el (nnslashdot-request-article) + (nnslashdot-retrieve-headers-1): Update to new HTML. + +2005-10-23 Simon Josefsson <jas@extundo.com> + + * imap.el (imap-gssapi-program): Align command line parameters + with latest GNU SASL. + (imap-gssapi-open): Ignore 'Trying ...' messages from GNU SASL. + +2005-10-20 Hiroshi Fujishima <hiroshi.fujishima@gmail.com> (tiny change) + + * mail-source.el (mail-source-fetch-pop): Require pop3. + (mail-source-check-pop): Ditto. + +2005-10-20 Katsumi Yamaoka <yamaoka@jpl.org> + + * rfc2047.el (rfc2047-decode-encoded-words): Fix the handling of + errors. + +2005-10-19 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-art.el (gnus-treat-strip-trailing-blank-lines) + (gnus-treat-strip-leading-blank-lines): Improve doc string. + + * message.el (message-tool-bar-local-item-from-menu): Fix comment. + +2005-10-19 Katsumi Yamaoka <yamaoka@jpl.org> + + * rfc2047.el (rfc2047-allow-incomplete-encoded-text): New variable. + (rfc2047-charset-to-coding-system): New function. + (rfc2047-decode-encoded-words): New function. + (rfc2047-decode-region): Use them. + (rfc2047-decode-cte): Remove. + (rfc2047-parse-and-decode): Remove. + (rfc2047-decode): Remove. + +2005-10-15 Kenichi Handa <handa@m17n.org> + + * rfc2047.el (rfc2047-decode-cte): New function. + (rfc2047-decode-region): Change the way to decode successive + encoded-words: decode B- or Q-encoding in each encoded-word, + concatenate them, and decode it as charset. + 2005-10-17 Chong Yidong <cyd@stupidchicken.com> * gnus-cus.el (gnus-custom-map): New variable. Bind mouse-1 to diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 249325a06f0..98e699cd80c 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -1181,7 +1181,10 @@ See Info node `(gnus)Customizing Articles' for details." (defcustom gnus-treat-strip-trailing-blank-lines nil "Strip trailing blank lines. Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details." +See Info node `(gnus)Customizing Articles' for details. + +When set to t, it also strips trailing blanks in all MIME parts. +Consider to use `last' instead." :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) @@ -1189,7 +1192,9 @@ See Info node `(gnus)Customizing Articles' for details." (defcustom gnus-treat-strip-leading-blank-lines nil "Strip leading blank lines. Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details." +See Info node `(gnus)Customizing Articles' for details. + +When set to t, it also strips trailing blanks in all MIME parts." :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) diff --git a/lisp/gnus/gnus-score.el b/lisp/gnus/gnus-score.el index 22a579c3d69..2858ecb8343 100644 --- a/lisp/gnus/gnus-score.el +++ b/lisp/gnus/gnus-score.el @@ -221,13 +221,22 @@ This variable allows the same syntax as `gnus-home-score-file'." (function :value fun))) (defcustom gnus-default-adaptive-score-alist - '((gnus-kill-file-mark) + `((gnus-kill-file-mark) (gnus-unread-mark) - (gnus-read-mark (from 3) (subject 30)) - (gnus-catchup-mark (subject -10)) - (gnus-killed-mark (from -1) (subject -20)) - (gnus-del-mark (from -2) (subject -15))) - "*Alist of marks and scores." + (gnus-read-mark + (from , (+ 2 gnus-score-decay-constant)) + (subject , (+ 27 gnus-score-decay-constant))) + (gnus-catchup-mark + (subject , (+ -7 (* -1 gnus-score-decay-constant)))) + (gnus-killed-mark + (from , (- -1 gnus-score-decay-constant)) + (subject , (+ -17 (* -1 gnus-score-decay-constant)))) + (gnus-del-mark + (from , (- -1 gnus-score-decay-constant)) + (subject , (+ -12 (* -1 gnus-score-decay-constant))))) + "Alist of marks and scores. +If you use score decays, you might want to set values higher than +`gnus-score-decay-constant'." :group 'gnus-score-adapt :type '(repeat (cons (symbol :tag "Mark") (repeat (list (choice :tag "Header" diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index c9e93d19f42..51f03061d4f 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -1000,7 +1000,9 @@ which it may alter in any way." :type '(repeat symbol)) (defcustom gnus-ignored-from-addresses - (and user-mail-address (regexp-quote user-mail-address)) + (and user-mail-address + (not (string= user-mail-address "")) + (regexp-quote user-mail-address)) "*Regexp of From headers that may be suppressed in favor of To headers." :version "21.1" :group 'gnus-summary diff --git a/lisp/gnus/imap.el b/lisp/gnus/imap.el index 062f1be4c94..b66d9eded8a 100644 --- a/lisp/gnus/imap.el +++ b/lisp/gnus/imap.el @@ -182,8 +182,7 @@ the list is tried until a successful connection is made." :type '(repeat string)) (defcustom imap-gssapi-program (list - (concat "gsasl --client --connect %s:%p " - "--imap --application-data " + (concat "gsasl %s %p " "--mechanism GSSAPI " "--authentication-id %l") "imtest -m gssapi -u %l -p %p %s") @@ -600,6 +599,10 @@ sure of changing the value of `foo'." (or (not (looking-at "S: ")) (forward-char 3) t) + ;; GNU SASL may print 'Trying ...' first. + (or (not (looking-at "Trying ")) + (forward-line) + t) (not (and (imap-parse-greeting) ;; success in imtest 1.6: (re-search-forward diff --git a/lisp/gnus/mail-source.el b/lisp/gnus/mail-source.el index 3f3ecc7919f..c31fa6825f4 100644 --- a/lisp/gnus/mail-source.el +++ b/lisp/gnus/mail-source.el @@ -740,6 +740,7 @@ Pass INFO on to CALLBACK." (funcall function mail-source-crash-box)) ;; The default is to use pop3.el. (t + (require 'pop3) (let ((pop3-password password) (pop3-maildrop user) (pop3-mailhost server) @@ -801,6 +802,7 @@ Pass INFO on to CALLBACK." (function) ;; The default is to use pop3.el. (t + (require 'pop3) (let ((pop3-password password) (pop3-maildrop user) (pop3-mailhost server) diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 8ac3bb8cf18..06039347acc 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -6565,9 +6565,8 @@ which specify the range to operate on." (defun message-tool-bar-local-item-from-menu (command icon in-map &optional from-map &rest props) ;; We need to make tool bar entries in local keymaps with - ;; `tool-bar-local-item-from-menu' in Emacs > 21.3 + ;; `tool-bar-local-item-from-menu' in Emacs >= 22 (if (fboundp 'tool-bar-local-item-from-menu) - ;; This is for Emacs 21.3 (tool-bar-local-item-from-menu command icon in-map from-map props) (tool-bar-add-item-from-menu command icon from-map props))) diff --git a/lisp/gnus/nnslashdot.el b/lisp/gnus/nnslashdot.el index 9350a284e3d..522f94acabc 100644 --- a/lisp/gnus/nnslashdot.el +++ b/lisp/gnus/nnslashdot.el @@ -87,7 +87,7 @@ (nnslashdot-possibly-change-server group server) (condition-case why (unless gnus-nov-is-evil - (nnslashdot-retrieve-headers-1 articles group)) + (nnslashdot-retrieve-headers-1 articles group)) (search-failed (nnslashdot-lose why)))) (deffoo nnslashdot-retrieve-headers-1 (articles group) @@ -142,41 +142,30 @@ (setq article (if (and article (< start article)) article start)) (goto-char point) (while (re-search-forward - "<a name=\"\\([0-9]+\\)\"><\\(b\\|H4\\)>\\([^<]+\\)</\\(b\\|H4\\)>.*score:\\([^)]+\\))" + "<a name=\"\\([0-9]+\\)\">\\([^<]+\\)</a>.*\n.*score:\\([^)]+\\))" nil t) (setq cid (match-string 1) - subject (match-string 3) - score (match-string 5)) + subject (match-string 2) + score (match-string 3)) (unless (assq article (nth 4 entry)) (setcar (nthcdr 4 entry) (cons (cons article cid) (nth 4 entry))) (setq changed t)) (when (string-match "^Re: *" subject) (setq subject (concat "Re: " (substring subject (match-end 0))))) - (setq subject (mm-url-decode-entities-string subject)) - (search-forward "<BR>") - (cond - ((looking-at - "by[ \t\n]+<a[^>]+>\\([^<]+\\)</a>[ \t\n]*(\\(<[^>]+>\\)*\\([^<>)]+\\))") - (goto-char (- (match-end 0) 5)) - (setq from (concat - (mm-url-decode-entities-string (match-string 1)) - " <" (match-string 3) ">"))) - ((looking-at "by[ \t\n]+<a[^>]+>\\([^<(]+\\) (\\([0-9]+\\))</a>") - (goto-char (- (match-end 0) 5)) - (setq from (concat - (mm-url-decode-entities-string (match-string 1)) - " <" (match-string 2) ">"))) - ((looking-at "by \\([^<>]*\\)[\t\n\r ]+on ") - (goto-char (- (match-end 0) 5)) - (setq from (mm-url-decode-entities-string (match-string 1)))) - (t - (setq from ""))) + (setq subject (mm-url-decode-entities-string subject) + from "") + (when (re-search-forward "by[ \t\n]+<[^>]+>\\([^<(]+\\)" nil t) + (setq from + (concat + (mm-url-decode-entities-string (match-string 1)) + " <nobody@slashdot.org>"))) (search-forward "on ") (setq date (nnslashdot-date-to-date - (buffer-substring (point) (progn (skip-chars-forward "^()<>\n\r") (point))))) - (setq lines (/ (abs (- (search-forward "<td") - (search-forward "</td>"))) + (buffer-substring + (point) (progn (skip-chars-forward "^()<>\n\r") (point))))) + (setq lines (/ (abs (- (search-forward "<div") + (search-forward "</div>"))) 70)) (if (not (re-search-forward ".*cid=\\([0-9]+\\)\">Parent</A>" nil t)) @@ -255,23 +244,21 @@ (when (numberp article) (if (= article 1) (progn - (re-search-forward - "Posted by") - (search-forward "<BR>") + (search-forward "Posted by") + (search-forward "<div class=\"intro\">") (setq contents (buffer-substring (point) (progn - (re-search-forward - "<IFRAME\\|<SCRIPT LANGUAGE=\"JAVASCRIPT\">\\|<!-- no ad 6 -->\\|< [ \t\r\n]*<A HREF=\"\\(\\(http:\\)?//slashdot\\.org\\)?/article") + (search-forward "commentwrap") (match-beginning 0))))) (setq cid (cdr (assq article (nth 4 (assoc group nnslashdot-groups))))) (search-forward (format "<a name=\"%s\">" cid)) (setq contents (buffer-substring - (re-search-forward "<td[^>]*>") - (search-forward "</td>"))))))) + (search-forward "<div class=\"commentBody\">") + (search-forward "</div>"))))))) (search-failed (nnslashdot-lose why))) (when contents diff --git a/lisp/gnus/pgg-def.el b/lisp/gnus/pgg-def.el deleted file mode 100644 index c6197db447d..00000000000 --- a/lisp/gnus/pgg-def.el +++ /dev/null @@ -1,91 +0,0 @@ -;;; pgg-def.el --- functions/macros for defining PGG functions - -;; Copyright (C) 1999, 2002, 2003, 2004, 2005 Free Software Foundation, Inc. - -;; Author: Daiki Ueno <ueno@unixuser.org> -;; Created: 1999/11/02 -;; Keywords: PGP, OpenPGP, GnuPG - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Code: - -(defgroup pgg () - "Glue for the various PGP implementations." - :group 'mime - :version "22.1") - -(defcustom pgg-default-scheme 'gpg - "Default PGP scheme." - :group 'pgg - :type '(choice (const :tag "GnuPG" gpg) - (const :tag "PGP 5" pgp5) - (const :tag "PGP" pgp))) - -(defcustom pgg-default-user-id (user-login-name) - "User ID of your default identity." - :group 'pgg - :type 'string) - -(defcustom pgg-default-keyserver-address "subkeys.pgp.net" - "Host name of keyserver." - :group 'pgg - :type 'string) - -(defcustom pgg-query-keyserver nil - "Whether PGG queries keyservers for missing keys when verifying messages." - :version "22.1" - :group 'pgg - :type 'boolean) - -(defcustom pgg-encrypt-for-me t - "If t, encrypt all outgoing messages with user's public key." - :group 'pgg - :type 'boolean) - -(defcustom pgg-cache-passphrase t - "If t, cache passphrase." - :group 'pgg - :type 'boolean) - -(defcustom pgg-passphrase-cache-expiry 16 - "How many seconds the passphrase is cached. -Whether the passphrase is cached at all is controlled by -`pgg-cache-passphrase'." - :group 'pgg - :type 'integer) - -(defvar pgg-messages-coding-system nil - "Coding system used when reading from a PGP external process.") - -(defvar pgg-status-buffer " *PGG status*") -(defvar pgg-errors-buffer " *PGG errors*") -(defvar pgg-output-buffer " *PGG output*") - -(defvar pgg-echo-buffer "*PGG-echo*") - -(defvar pgg-scheme nil - "Current scheme of PGP implementation.") - -(defmacro pgg-truncate-key-identifier (key) - `(if (> (length ,key) 8) (substring ,key 8) ,key)) - -(provide 'pgg-def) - -;;; arch-tag: c425f3ab-ed75-4055-bb46-431a418c94b7 -;;; pgg-def.el ends here diff --git a/lisp/gnus/pgg-gpg.el b/lisp/gnus/pgg-gpg.el deleted file mode 100644 index 6ba017c731c..00000000000 --- a/lisp/gnus/pgg-gpg.el +++ /dev/null @@ -1,275 +0,0 @@ -;;; pgg-gpg.el --- GnuPG support for PGG. - -;; Copyright (C) 1999, 2000, 2002, 2003, 2004, -;; 2005 Free Software Foundation, Inc. - -;; Author: Daiki Ueno <ueno@unixuser.org> -;; Created: 1999/10/28 -;; Keywords: PGP, OpenPGP, GnuPG - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Code: - -(eval-when-compile - (require 'cl) ; for gpg macros - (require 'pgg)) - -(defgroup pgg-gpg () - "GnuPG interface." - :group 'pgg) - -(defcustom pgg-gpg-program "gpg" - "The GnuPG executable." - :group 'pgg-gpg - :type 'string) - -(defcustom pgg-gpg-extra-args nil - "Extra arguments for every GnuPG invocation." - :group 'pgg-gpg - :type '(repeat (string :tag "Argument"))) - -(defcustom pgg-gpg-recipient-argument "--recipient" - "GnuPG option to specify recipient." - :group 'pgg-gpg - :type '(choice (const :tag "New `--recipient' option" "--recipient") - (const :tag "Old `--remote-user' option" "--remote-user"))) - -(defvar pgg-gpg-user-id nil - "GnuPG ID of your default identity.") - -(defun pgg-gpg-process-region (start end passphrase program args) - (let* ((output-file-name (pgg-make-temp-file "pgg-output")) - (args - `("--status-fd" "2" - ,@(if passphrase '("--passphrase-fd" "0")) - "--yes" ; overwrite - "--output" ,output-file-name - ,@pgg-gpg-extra-args ,@args)) - (output-buffer pgg-output-buffer) - (errors-buffer pgg-errors-buffer) - (orig-mode (default-file-modes)) - (process-connection-type nil) - exit-status) - (with-current-buffer (get-buffer-create errors-buffer) - (buffer-disable-undo) - (erase-buffer)) - (unwind-protect - (progn - (set-default-file-modes 448) - (let ((coding-system-for-write 'binary) - (input (buffer-substring-no-properties start end)) - (default-enable-multibyte-characters nil)) - (with-temp-buffer - (when passphrase - (insert passphrase "\n")) - (insert input) - (setq exit-status - (apply #'call-process-region (point-min) (point-max) program - nil errors-buffer nil args)))) - (with-current-buffer (get-buffer-create output-buffer) - (buffer-disable-undo) - (erase-buffer) - (if (file-exists-p output-file-name) - (let ((coding-system-for-read 'raw-text-dos)) - (insert-file-contents output-file-name))) - (set-buffer errors-buffer) - (if (not (equal exit-status 0)) - (insert (format "\n%s exited abnormally: '%s'\n" - program exit-status))))) - (if (file-exists-p output-file-name) - (delete-file output-file-name)) - (set-default-file-modes orig-mode)))) - -(defun pgg-gpg-possibly-cache-passphrase (passphrase &optional key) - (if (and pgg-cache-passphrase - (progn - (goto-char (point-min)) - (re-search-forward "^\\[GNUPG:] \\(GOOD_PASSPHRASE\\>\\)\\|\\(SIG_CREATED\\)" nil t))) - (pgg-add-passphrase-cache - (or key - (progn - (goto-char (point-min)) - (if (re-search-forward - "^\\[GNUPG:] NEED_PASSPHRASE\\(_PIN\\)? \\w+ ?\\w*" nil t) - (substring (match-string 0) -8)))) - passphrase))) - -(defvar pgg-gpg-all-secret-keys 'unknown) - -(defun pgg-gpg-lookup-all-secret-keys () - "Return all secret keys present in secret key ring." - (when (eq pgg-gpg-all-secret-keys 'unknown) - (setq pgg-gpg-all-secret-keys '()) - (let ((args (list "--with-colons" "--no-greeting" "--batch" - "--list-secret-keys"))) - (with-temp-buffer - (apply #'call-process pgg-gpg-program nil t nil args) - (goto-char (point-min)) - (while (re-search-forward - "^\\(sec\\|pub\\):[^:]*:[^:]*:[^:]*:\\([^:]*\\)" nil t) - (push (substring (match-string 2) 8) - pgg-gpg-all-secret-keys))))) - pgg-gpg-all-secret-keys) - -(defun pgg-gpg-lookup-key (string &optional type) - "Search keys associated with STRING." - (let ((args (list "--with-colons" "--no-greeting" "--batch" - (if type "--list-secret-keys" "--list-keys") - string))) - (with-temp-buffer - (apply #'call-process pgg-gpg-program nil t nil args) - (goto-char (point-min)) - (if (re-search-forward "^\\(sec\\|pub\\):[^:]*:[^:]*:[^:]*:\\([^:]*\\)" - nil t) - (substring (match-string 2) 8))))) - -(defun pgg-gpg-encrypt-region (start end recipients &optional sign) - "Encrypt the current region between START and END. -If optional argument SIGN is non-nil, do a combined sign and encrypt." - (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id)) - (passphrase - (when sign - (pgg-read-passphrase - (format "GnuPG passphrase for %s: " pgg-gpg-user-id) - pgg-gpg-user-id))) - (args - (append - (list "--batch" "--armor" "--always-trust" "--encrypt") - (if sign (list "--sign" "--local-user" pgg-gpg-user-id)) - (if recipients - (apply #'nconc - (mapcar (lambda (rcpt) - (list pgg-gpg-recipient-argument rcpt)) - (append recipients - (if pgg-encrypt-for-me - (list pgg-gpg-user-id))))))))) - (pgg-as-lbt start end 'CRLF - (pgg-gpg-process-region start end passphrase pgg-gpg-program args)) - (when sign - (with-current-buffer pgg-errors-buffer - ;; Possibly cache passphrase under, e.g. "jas", for future sign. - (pgg-gpg-possibly-cache-passphrase passphrase pgg-gpg-user-id) - ;; Possibly cache passphrase under, e.g. B565716F, for future decrypt. - (pgg-gpg-possibly-cache-passphrase passphrase))) - (pgg-process-when-success))) - -(defun pgg-gpg-decrypt-region (start end) - "Decrypt the current region between START and END." - (let* ((current-buffer (current-buffer)) - (message-keys (with-temp-buffer - (insert-buffer-substring current-buffer) - (pgg-decode-armor-region (point-min) (point-max)))) - (secret-keys (pgg-gpg-lookup-all-secret-keys)) - (key (pgg-gpg-select-matching-key message-keys secret-keys)) - (pgg-gpg-user-id (or key pgg-gpg-user-id pgg-default-user-id)) - (passphrase - (pgg-read-passphrase - (format "GnuPG passphrase for %s: " pgg-gpg-user-id) - pgg-gpg-user-id)) - (args '("--batch" "--decrypt"))) - (pgg-gpg-process-region start end passphrase pgg-gpg-program args) - (with-current-buffer pgg-errors-buffer - (pgg-gpg-possibly-cache-passphrase passphrase pgg-gpg-user-id) - (goto-char (point-min)) - (re-search-forward "^\\[GNUPG:] DECRYPTION_OKAY\\>" nil t)))) - -(defun pgg-gpg-select-matching-key (message-keys secret-keys) - "Choose a key from MESSAGE-KEYS that matches one of the keys in SECRET-KEYS." - (loop for message-key in message-keys - for message-key-id = (and (equal (car message-key) 1) - (cdr (assq 'key-identifier message-key))) - for key = (and message-key-id (pgg-lookup-key message-key-id 'encrypt)) - when (and key (member key secret-keys)) return key)) - -(defun pgg-gpg-sign-region (start end &optional cleartext) - "Make detached signature from text between START and END." - (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id)) - (passphrase - (pgg-read-passphrase - (format "GnuPG passphrase for %s: " pgg-gpg-user-id) - pgg-gpg-user-id)) - (args - (list (if cleartext "--clearsign" "--detach-sign") - "--armor" "--batch" "--verbose" - "--local-user" pgg-gpg-user-id)) - (inhibit-read-only t) - buffer-read-only) - (pgg-as-lbt start end 'CRLF - (pgg-gpg-process-region start end passphrase pgg-gpg-program args)) - (with-current-buffer pgg-errors-buffer - ;; Possibly cache passphrase under, e.g. "jas", for future sign. - (pgg-gpg-possibly-cache-passphrase passphrase pgg-gpg-user-id) - ;; Possibly cache passphrase under, e.g. B565716F, for future decrypt. - (pgg-gpg-possibly-cache-passphrase passphrase)) - (pgg-process-when-success))) - -(defun pgg-gpg-verify-region (start end &optional signature) - "Verify region between START and END as the detached signature SIGNATURE." - (let ((args '("--batch" "--verify"))) - (when (stringp signature) - (setq args (append args (list signature)))) - (setq args (append args '("-"))) - (pgg-gpg-process-region start end nil pgg-gpg-program args) - (with-current-buffer pgg-errors-buffer - (goto-char (point-min)) - (while (re-search-forward "^gpg: \\(.*\\)\n" nil t) - (with-current-buffer pgg-output-buffer - (insert-buffer-substring pgg-errors-buffer - (match-beginning 1) (match-end 0))) - (delete-region (match-beginning 0) (match-end 0))) - (goto-char (point-min)) - (re-search-forward "^\\[GNUPG:] GOODSIG\\>" nil t)))) - -(defun pgg-gpg-insert-key () - "Insert public key at point." - (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id)) - (args (list "--batch" "--export" "--armor" - pgg-gpg-user-id))) - (pgg-gpg-process-region (point)(point) nil pgg-gpg-program args) - (insert-buffer-substring pgg-output-buffer))) - -(defun pgg-gpg-snarf-keys-region (start end) - "Add all public keys in region between START and END to the keyring." - (let ((args '("--import" "--batch" "-")) status) - (pgg-gpg-process-region start end nil pgg-gpg-program args) - (set-buffer pgg-errors-buffer) - (goto-char (point-min)) - (when (re-search-forward "^\\[GNUPG:] IMPORT_RES\\>" nil t) - (setq status (buffer-substring (match-end 0) - (progn (end-of-line)(point))) - status (vconcat (mapcar #'string-to-number (split-string status)))) - (erase-buffer) - (insert (format "Imported %d key(s). -\tArmor contains %d key(s) [%d bad, %d old].\n" - (+ (aref status 2) - (aref status 10)) - (aref status 0) - (aref status 1) - (+ (aref status 4) - (aref status 11))) - (if (zerop (aref status 9)) - "" - "\tSecret keys are imported.\n"))) - (append-to-buffer pgg-output-buffer (point-min)(point-max)) - (pgg-process-when-success))) - -(provide 'pgg-gpg) - -;;; arch-tag: 2aa5d5d8-93a0-4865-9312-33e29830e000 -;;; pgg-gpg.el ends here diff --git a/lisp/gnus/pgg-parse.el b/lisp/gnus/pgg-parse.el deleted file mode 100644 index 422ccc6ac23..00000000000 --- a/lisp/gnus/pgg-parse.el +++ /dev/null @@ -1,515 +0,0 @@ -;;; pgg-parse.el --- OpenPGP packet parsing - -;; Copyright (C) 1999, 2002, 2003, 2004, 2005 Free Software Foundation, Inc. - -;; Author: Daiki Ueno <ueno@unixuser.org> -;; Created: 1999/10/28 -;; Keywords: PGP, OpenPGP, GnuPG - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;; This module is based on - -;; [OpenPGP] RFC 2440: "OpenPGP Message Format" -;; by John W. Noerenberg, II <jwn2@qualcomm.com>, -;; Jon Callas <jon@pgp.com>, Lutz Donnerhacke <lutz@iks-jena.de>, -;; Hal Finney <hal@pgp.com> and Rodney Thayer <rodney@unitran.com> -;; (1998/11) - -;;; Code: - -(eval-when-compile (require 'cl)) - -(defgroup pgg-parse () - "OpenPGP packet parsing." - :group 'pgg) - -(defcustom pgg-parse-public-key-algorithm-alist - '((1 . RSA) (2 . RSA-E) (3 . RSA-S) (16 . ELG-E) (17 . DSA) (20 . ELG)) - "Alist of the assigned number to the public key algorithm." - :group 'pgg-parse - :type '(repeat - (cons (sexp :tag "Number") (sexp :tag "Type")))) - -(defcustom pgg-parse-symmetric-key-algorithm-alist - '((1 . IDEA) (2 . 3DES) (4 . CAST5) (5 . SAFER-SK128)) - "Alist of the assigned number to the simmetric key algorithm." - :group 'pgg-parse - :type '(repeat - (cons (sexp :tag "Number") (sexp :tag "Type")))) - -(defcustom pgg-parse-hash-algorithm-alist - '((1 . MD5) (2 . SHA1) (3 . RIPEMD160) (5 . MD2) (8 . SHA256) (9 . SHA384) - (10 . SHA512)) - "Alist of the assigned number to the cryptographic hash algorithm." - :group 'pgg-parse - :type '(repeat - (cons (sexp :tag "Number") (sexp :tag "Type")))) - -(defcustom pgg-parse-compression-algorithm-alist - '((0 . nil); Uncompressed - (1 . ZIP) - (2 . ZLIB)) - "Alist of the assigned number to the compression algorithm." - :group 'pgg-parse - :type '(repeat - (cons (sexp :tag "Number") (sexp :tag "Type")))) - -(defcustom pgg-parse-signature-type-alist - '((0 . "Signature of a binary document") - (1 . "Signature of a canonical text document") - (2 . "Standalone signature") - (16 . "Generic certification of a User ID and Public Key packet") - (17 . "Persona certification of a User ID and Public Key packet") - (18 . "Casual certification of a User ID and Public Key packet") - (19 . "Positive certification of a User ID and Public Key packet") - (24 . "Subkey Binding Signature") - (31 . "Signature directly on a key") - (32 . "Key revocation signature") - (40 . "Subkey revocation signature") - (48 . "Certification revocation signature") - (64 . "Timestamp signature.")) - "Alist of the assigned number to the signature type." - :group 'pgg-parse - :type '(repeat - (cons (sexp :tag "Number") (sexp :tag "Type")))) - -(defcustom pgg-ignore-packet-checksum t; XXX - "If non-nil checksum of each ascii armored packet will be ignored." - :group 'pgg-parse - :type 'boolean) - -(defvar pgg-armor-header-lines - '("^-----BEGIN PGP MESSAGE\\(, PART [0-9]+\\(/[0-9]+\\)?\\)?-----\r?$" - "^-----BEGIN PGP PUBLIC KEY BLOCK-----\r?$" - "^-----BEGIN PGP PRIVATE KEY BLOCK-----\r?$" - "^-----BEGIN PGP SIGNATURE-----\r?$") - "Armor headers.") - -(eval-and-compile - (defalias 'pgg-char-int (if (fboundp 'char-int) - 'char-int - 'identity))) - -(defmacro pgg-format-key-identifier (string) - `(mapconcat (lambda (c) (format "%02X" (pgg-char-int c))) - ,string "") - ;; `(upcase (apply #'format "%02x%02x%02x%02x%02x%02x%02x%02x" - ;; (string-to-number-list ,string))) - ) - -(defmacro pgg-parse-time-field (bytes) - `(list (logior (lsh (car ,bytes) 8) - (nth 1 ,bytes)) - (logior (lsh (nth 2 ,bytes) 8) - (nth 3 ,bytes)) - 0)) - -(defmacro pgg-byte-after (&optional pos) - `(pgg-char-int (char-after ,(or pos `(point))))) - -(defmacro pgg-read-byte () - `(pgg-char-int (char-after (prog1 (point) (forward-char))))) - -(defmacro pgg-read-bytes-string (nbytes) - `(buffer-substring - (point) (prog1 (+ ,nbytes (point)) - (forward-char ,nbytes)))) - -(defmacro pgg-read-bytes (nbytes) - `(mapcar #'pgg-char-int (pgg-read-bytes-string ,nbytes)) - ;; `(string-to-number-list (pgg-read-bytes-string ,nbytes)) - ) - -(defmacro pgg-read-body-string (ptag) - `(if (nth 1 ,ptag) - (pgg-read-bytes-string (nth 1 ,ptag)) - (pgg-read-bytes-string (- (point-max) (point))))) - -(defmacro pgg-read-body (ptag) - `(mapcar #'pgg-char-int (pgg-read-body-string ,ptag)) - ;; `(string-to-number-list (pgg-read-body-string ,ptag)) - ) - -(defalias 'pgg-skip-bytes 'forward-char) - -(defmacro pgg-skip-header (ptag) - `(pgg-skip-bytes (nth 2 ,ptag))) - -(defmacro pgg-skip-body (ptag) - `(pgg-skip-bytes (nth 1 ,ptag))) - -(defmacro pgg-set-alist (alist key value) - `(setq ,alist (nconc ,alist (list (cons ,key ,value))))) - -(when (fboundp 'define-ccl-program) - - (define-ccl-program pgg-parse-crc24 - '(1 - ((loop - (read r0) (r1 ^= r0) (r2 ^= 0) - (r5 = 0) - (loop - (r1 <<= 1) - (r1 += ((r2 >> 15) & 1)) - (r2 <<= 1) - (if (r1 & 256) - ((r1 ^= 390) (r2 ^= 19707))) - (if (r5 < 7) - ((r5 += 1) - (repeat)))) - (repeat))))) - - (defun pgg-parse-crc24-string (string) - (let ((h (vector nil 183 1230 nil nil nil nil nil nil))) - (ccl-execute-on-string pgg-parse-crc24 h string) - (format "%c%c%c" - (logand (aref h 1) 255) - (logand (lsh (aref h 2) -8) 255) - (logand (aref h 2) 255))))) - -(defmacro pgg-parse-length-type (c) - `(cond - ((< ,c 192) (cons ,c 1)) - ((< ,c 224) - (cons (+ (lsh (- ,c 192) 8) - (pgg-byte-after (+ 2 (point))) - 192) - 2)) - ((= ,c 255) - (cons (cons (logior (lsh (pgg-byte-after (+ 2 (point))) 8) - (pgg-byte-after (+ 3 (point)))) - (logior (lsh (pgg-byte-after (+ 4 (point))) 8) - (pgg-byte-after (+ 5 (point))))) - 5)) - (t;partial body length - '(0 . 0)))) - -(defun pgg-parse-packet-header () - (let ((ptag (pgg-byte-after)) - length-type content-tag packet-bytes header-bytes) - (if (zerop (logand 64 ptag));Old format - (progn - (setq length-type (logand ptag 3) - length-type (if (= 3 length-type) 0 (lsh 1 length-type)) - content-tag (logand 15 (lsh ptag -2)) - packet-bytes 0 - header-bytes (1+ length-type)) - (dotimes (i length-type) - (setq packet-bytes - (logior (lsh packet-bytes 8) - (pgg-byte-after (+ 1 i (point))))))) - (setq content-tag (logand 63 ptag) - length-type (pgg-parse-length-type - (pgg-byte-after (1+ (point)))) - packet-bytes (car length-type) - header-bytes (1+ (cdr length-type)))) - (list content-tag packet-bytes header-bytes))) - -(defun pgg-parse-packet (ptag) - (case (car ptag) - (1 ;Public-Key Encrypted Session Key Packet - (pgg-parse-public-key-encrypted-session-key-packet ptag)) - (2 ;Signature Packet - (pgg-parse-signature-packet ptag)) - (3 ;Symmetric-Key Encrypted Session Key Packet - (pgg-parse-symmetric-key-encrypted-session-key-packet ptag)) - ;; 4 -- One-Pass Signature Packet - ;; 5 -- Secret Key Packet - (6 ;Public Key Packet - (pgg-parse-public-key-packet ptag)) - ;; 7 -- Secret Subkey Packet - ;; 8 -- Compressed Data Packet - (9 ;Symmetrically Encrypted Data Packet - (pgg-read-body-string ptag)) - (10 ;Marker Packet - (pgg-read-body-string ptag)) - (11 ;Literal Data Packet - (pgg-read-body-string ptag)) - ;; 12 -- Trust Packet - (13 ;User ID Packet - (pgg-read-body-string ptag)) - ;; 14 -- Public Subkey Packet - ;; 60 .. 63 -- Private or Experimental Values - )) - -(defun pgg-parse-packets (&optional header-parser body-parser) - (let ((header-parser - (or header-parser - (function pgg-parse-packet-header))) - (body-parser - (or body-parser - (function pgg-parse-packet))) - result ptag) - (while (> (point-max) (1+ (point))) - (setq ptag (funcall header-parser)) - (pgg-skip-header ptag) - (push (cons (car ptag) - (save-excursion - (funcall body-parser ptag))) - result) - (if (zerop (nth 1 ptag)) - (goto-char (point-max)) - (forward-char (nth 1 ptag)))) - result)) - -(defun pgg-parse-signature-subpacket-header () - (let ((length-type (pgg-parse-length-type (pgg-byte-after)))) - (list (pgg-byte-after (+ (cdr length-type) (point))) - (1- (car length-type)) - (1+ (cdr length-type))))) - -(defun pgg-parse-signature-subpacket (ptag) - (case (car ptag) - (2 ;signature creation time - (cons 'creation-time - (let ((bytes (pgg-read-bytes 4))) - (pgg-parse-time-field bytes)))) - (3 ;signature expiration time - (cons 'signature-expiry - (let ((bytes (pgg-read-bytes 4))) - (pgg-parse-time-field bytes)))) - (4 ;exportable certification - (cons 'exportability (pgg-read-byte))) - (5 ;trust signature - (cons 'trust-level (pgg-read-byte))) - (6 ;regular expression - (cons 'regular-expression - (pgg-read-body-string ptag))) - (7 ;revocable - (cons 'revocability (pgg-read-byte))) - (9 ;key expiration time - (cons 'key-expiry - (let ((bytes (pgg-read-bytes 4))) - (pgg-parse-time-field bytes)))) - ;; 10 = placeholder for backward compatibility - (11 ;preferred symmetric algorithms - (cons 'preferred-symmetric-key-algorithm - (cdr (assq (pgg-read-byte) - pgg-parse-symmetric-key-algorithm-alist)))) - (12 ;revocation key - ) - (16 ;issuer key ID - (cons 'key-identifier - (pgg-format-key-identifier (pgg-read-body-string ptag)))) - (20 ;notation data - (pgg-skip-bytes 4) - (cons 'notation - (let ((name-bytes (pgg-read-bytes 2)) - (value-bytes (pgg-read-bytes 2))) - (cons (pgg-read-bytes-string - (logior (lsh (car name-bytes) 8) - (nth 1 name-bytes))) - (pgg-read-bytes-string - (logior (lsh (car value-bytes) 8) - (nth 1 value-bytes))))))) - (21 ;preferred hash algorithms - (cons 'preferred-hash-algorithm - (cdr (assq (pgg-read-byte) - pgg-parse-hash-algorithm-alist)))) - (22 ;preferred compression algorithms - (cons 'preferred-compression-algorithm - (cdr (assq (pgg-read-byte) - pgg-parse-compression-algorithm-alist)))) - (23 ;key server preferences - (cons 'key-server-preferences - (pgg-read-body ptag))) - (24 ;preferred key server - (cons 'preferred-key-server - (pgg-read-body-string ptag))) - ;; 25 = primary user id - (26 ;policy URL - (cons 'policy-url (pgg-read-body-string ptag))) - ;; 27 = key flags - ;; 28 = signer's user id - ;; 29 = reason for revocation - ;; 100 to 110 = internal or user-defined - )) - -(defun pgg-parse-signature-packet (ptag) - (let* ((signature-version (pgg-byte-after)) - (result (list (cons 'version signature-version))) - hashed-material field n) - (cond - ((= signature-version 3) - (pgg-skip-bytes 2) - (setq hashed-material (pgg-read-bytes 5)) - (pgg-set-alist result - 'signature-type - (cdr (assq (pop hashed-material) - pgg-parse-signature-type-alist))) - (pgg-set-alist result - 'creation-time - (pgg-parse-time-field hashed-material)) - (pgg-set-alist result - 'key-identifier - (pgg-format-key-identifier - (pgg-read-bytes-string 8))) - (pgg-set-alist result - 'public-key-algorithm (pgg-read-byte)) - (pgg-set-alist result - 'hash-algorithm (pgg-read-byte))) - ((= signature-version 4) - (pgg-skip-bytes 1) - (pgg-set-alist result - 'signature-type - (cdr (assq (pgg-read-byte) - pgg-parse-signature-type-alist))) - (pgg-set-alist result - 'public-key-algorithm - (pgg-read-byte)) - (pgg-set-alist result - 'hash-algorithm (pgg-read-byte)) - (when (>= 10000 (setq n (pgg-read-bytes 2) - n (logior (lsh (car n) 8) - (nth 1 n)))) - (save-restriction - (narrow-to-region (point)(+ n (point))) - (nconc result - (mapcar (function cdr) ;remove packet types - (pgg-parse-packets - #'pgg-parse-signature-subpacket-header - #'pgg-parse-signature-subpacket))) - (goto-char (point-max)))) - (when (>= 10000 (setq n (pgg-read-bytes 2) - n (logior (lsh (car n) 8) - (nth 1 n)))) - (save-restriction - (narrow-to-region (point)(+ n (point))) - (nconc result - (mapcar (function cdr) ;remove packet types - (pgg-parse-packets - #'pgg-parse-signature-subpacket-header - #'pgg-parse-signature-subpacket))))))) - - (setcdr (setq field (assq 'public-key-algorithm - result)) - (cdr (assq (cdr field) - pgg-parse-public-key-algorithm-alist))) - (setcdr (setq field (assq 'hash-algorithm - result)) - (cdr (assq (cdr field) - pgg-parse-hash-algorithm-alist))) - result)) - -(defun pgg-parse-public-key-encrypted-session-key-packet (ptag) - (let (result) - (pgg-set-alist result - 'version (pgg-read-byte)) - (pgg-set-alist result - 'key-identifier - (pgg-format-key-identifier - (pgg-read-bytes-string 8))) - (pgg-set-alist result - 'public-key-algorithm - (cdr (assq (pgg-read-byte) - pgg-parse-public-key-algorithm-alist))) - result)) - -(defun pgg-parse-symmetric-key-encrypted-session-key-packet (ptag) - (let (result) - (pgg-set-alist result - 'version - (pgg-read-byte)) - (pgg-set-alist result - 'symmetric-key-algorithm - (cdr (assq (pgg-read-byte) - pgg-parse-symmetric-key-algorithm-alist))) - result)) - -(defun pgg-parse-public-key-packet (ptag) - (let* ((key-version (pgg-read-byte)) - (result (list (cons 'version key-version))) - field) - (cond - ((= 3 key-version) - (pgg-set-alist result - 'creation-time - (let ((bytes (pgg-read-bytes 4))) - (pgg-parse-time-field bytes))) - (pgg-set-alist result - 'key-expiry (pgg-read-bytes 2)) - (pgg-set-alist result - 'public-key-algorithm (pgg-read-byte))) - ((= 4 key-version) - (pgg-set-alist result - 'creation-time - (let ((bytes (pgg-read-bytes 4))) - (pgg-parse-time-field bytes))) - (pgg-set-alist result - 'public-key-algorithm (pgg-read-byte)))) - - (setcdr (setq field (assq 'public-key-algorithm - result)) - (cdr (assq (cdr field) - pgg-parse-public-key-algorithm-alist))) - result)) - -(defun pgg-decode-packets () - (if (re-search-forward "^=\\([A-Za-z0-9+/]\\{4\\}\\)$" nil t) - (let ((p (match-beginning 0)) - (checksum (match-string 1))) - (delete-region p (point-max)) - (if (ignore-errors (base64-decode-region (point-min) p)) - (or (not (fboundp 'pgg-parse-crc24-string)) - pgg-ignore-packet-checksum - (string-equal (base64-encode-string (pgg-parse-crc24-string - (buffer-string))) - checksum) - (progn - (message "PGP packet checksum does not match") - nil)) - (message "PGP packet contain invalid base64") - nil)) - (message "PGP packet checksum not found") - nil)) - -(defun pgg-decode-armor-region (start end) - (save-restriction - (narrow-to-region start end) - (goto-char (point-min)) - (re-search-forward "^-+BEGIN PGP" nil t) - (delete-region (point-min) - (and (search-forward "\n\n") - (match-end 0))) - (when (pgg-decode-packets) - (goto-char (point-min)) - (pgg-parse-packets)))) - -(defun pgg-parse-armor (string) - (with-temp-buffer - (buffer-disable-undo) - (if (fboundp 'set-buffer-multibyte) - (set-buffer-multibyte nil)) - (insert string) - (pgg-decode-armor-region (point-min)(point)))) - -(eval-and-compile - (defalias 'pgg-string-as-unibyte (if (fboundp 'string-as-unibyte) - 'string-as-unibyte - 'identity))) - -(defun pgg-parse-armor-region (start end) - (pgg-parse-armor (pgg-string-as-unibyte (buffer-substring start end)))) - -(provide 'pgg-parse) - -;;; arch-tag: 16c2eb82-1313-4a7c-a70f-420709b5b43e -;;; pgg-parse.el ends here diff --git a/lisp/gnus/pgg-pgp.el b/lisp/gnus/pgg-pgp.el deleted file mode 100644 index 2735a0b7b27..00000000000 --- a/lisp/gnus/pgg-pgp.el +++ /dev/null @@ -1,245 +0,0 @@ -;;; pgg-pgp.el --- PGP 2.* and 6.* support for PGG. - -;; Copyright (C) 1999, 2000, 2002, 2003, 2004, -;; 2005 Free Software Foundation, Inc. - -;; Author: Daiki Ueno <ueno@unixuser.org> -;; Created: 1999/11/02 -;; Keywords: PGP, OpenPGP - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Code: - -(eval-when-compile - (require 'cl) ; for pgg macros - (require 'pgg)) - -(defgroup pgg-pgp () - "PGP 2.* and 6.* interface." - :group 'pgg) - -(defcustom pgg-pgp-program "pgp" - "PGP 2.* and 6.* executable." - :group 'pgg-pgp - :type 'string) - -(defcustom pgg-pgp-shell-file-name "/bin/sh" - "File name to load inferior shells from. -Bourne shell or its equivalent \(not tcsh) is needed for \"2>\"." - :group 'pgg-pgp - :type 'string) - -(defcustom pgg-pgp-shell-command-switch "-c" - "Switch used to have the shell execute its command line argument." - :group 'pgg-pgp - :type 'string) - -(defcustom pgg-pgp-extra-args nil - "Extra arguments for every PGP invocation." - :group 'pgg-pgp - :type '(choice - (const :tag "None" nil) - (string :tag "Arguments"))) - -(defvar pgg-pgp-user-id nil - "PGP ID of your default identity.") - -(defun pgg-pgp-process-region (start end passphrase program args) - (let* ((errors-file-name (pgg-make-temp-file "pgg-errors")) - (args - (append args - pgg-pgp-extra-args - (list (concat "2>" errors-file-name)))) - (shell-file-name pgg-pgp-shell-file-name) - (shell-command-switch pgg-pgp-shell-command-switch) - (process-environment process-environment) - (output-buffer pgg-output-buffer) - (errors-buffer pgg-errors-buffer) - (process-connection-type nil) - process status exit-status) - (with-current-buffer (get-buffer-create output-buffer) - (buffer-disable-undo) - (erase-buffer)) - (when passphrase - (setenv "PGPPASSFD" "0")) - (unwind-protect - (progn - (let ((coding-system-for-read 'binary) - (coding-system-for-write 'binary)) - (setq process - (apply #'funcall - #'start-process-shell-command "*PGP*" output-buffer - program args))) - (set-process-sentinel process #'ignore) - (when passphrase - (process-send-string process (concat passphrase "\n"))) - (process-send-region process start end) - (process-send-eof process) - (while (eq 'run (process-status process)) - (accept-process-output process 5)) - (setq status (process-status process) - exit-status (process-exit-status process)) - (delete-process process) - (with-current-buffer output-buffer - (pgg-convert-lbt-region (point-min)(point-max) 'LF) - - (if (memq status '(stop signal)) - (error "%s exited abnormally: '%s'" program exit-status)) - (if (= 127 exit-status) - (error "%s could not be found" program)) - - (set-buffer (get-buffer-create errors-buffer)) - (buffer-disable-undo) - (erase-buffer) - (insert-file-contents errors-file-name))) - (if (and process (eq 'run (process-status process))) - (interrupt-process process)) - (condition-case nil - (delete-file errors-file-name) - (file-error nil))))) - -(defun pgg-pgp-lookup-key (string &optional type) - "Search keys associated with STRING." - (let ((args (list "+batchmode" "+language=en" "-kv" string))) - (with-current-buffer (get-buffer-create pgg-output-buffer) - (buffer-disable-undo) - (erase-buffer) - (apply #'call-process pgg-pgp-program nil t nil args) - (goto-char (point-min)) - (cond - ((re-search-forward "^pub\\s +[0-9]+/" nil t);PGP 2.* - (buffer-substring (point)(+ 8 (point)))) - ((re-search-forward "^Type" nil t);PGP 6.* - (beginning-of-line 2) - (substring - (nth 2 (split-string - (buffer-substring (point)(progn (end-of-line) (point))))) - 2)))))) - -(defun pgg-pgp-encrypt-region (start end recipients) - "Encrypt the current region between START and END." - (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id)) - (args - `("+encrypttoself=off +verbose=1" "+batchmode" - "+language=us" "-fate" - ,@(if recipients - (mapcar (lambda (rcpt) (concat "\"" rcpt "\"")) - (append recipients - (if pgg-encrypt-for-me - (list pgg-pgp-user-id)))))))) - (pgg-pgp-process-region start end nil pgg-pgp-program args) - (pgg-process-when-success nil))) - -(defun pgg-pgp-decrypt-region (start end) - "Decrypt the current region between START and END." - (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id)) - (key (pgg-pgp-lookup-key pgg-pgp-user-id 'encrypt)) - (passphrase - (pgg-read-passphrase - (format "PGP passphrase for %s: " pgg-pgp-user-id) key)) - (args - '("+verbose=1" "+batchmode" "+language=us" "-f"))) - (pgg-pgp-process-region start end passphrase pgg-pgp-program args) - (pgg-process-when-success - (if pgg-cache-passphrase - (pgg-add-passphrase-cache key passphrase))))) - -(defun pgg-pgp-sign-region (start end &optional clearsign) - "Make detached signature from text between START and END." - (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id)) - (passphrase - (pgg-read-passphrase - (format "PGP passphrase for %s: " pgg-pgp-user-id) - (pgg-pgp-lookup-key pgg-pgp-user-id 'sign))) - (args - (list (if clearsign "-fast" "-fbast") - "+verbose=1" "+language=us" "+batchmode" - "-u" pgg-pgp-user-id))) - (pgg-pgp-process-region start end passphrase pgg-pgp-program args) - (pgg-process-when-success - (goto-char (point-min)) - (when (re-search-forward "^-+BEGIN PGP" nil t);XXX - (let ((packet - (cdr (assq 2 (pgg-parse-armor-region - (progn (beginning-of-line 2) - (point)) - (point-max)))))) - (if pgg-cache-passphrase - (pgg-add-passphrase-cache - (cdr (assq 'key-identifier packet)) - passphrase))))))) - -(defun pgg-pgp-verify-region (start end &optional signature) - "Verify region between START and END as the detached signature SIGNATURE." - (let* ((orig-file (pgg-make-temp-file "pgg")) - (args '("+verbose=1" "+batchmode" "+language=us")) - (orig-mode (default-file-modes))) - (unwind-protect - (progn - (set-default-file-modes 448) - (let ((coding-system-for-write 'binary) - jka-compr-compression-info-list jam-zcat-filename-list) - (write-region start end orig-file))) - (set-default-file-modes orig-mode)) - (if (stringp signature) - (progn - (copy-file signature (setq signature (concat orig-file ".asc"))) - (setq args (append args (list signature orig-file)))) - (setq args (append args (list orig-file)))) - (pgg-pgp-process-region (point)(point) nil pgg-pgp-program args) - (delete-file orig-file) - (if signature (delete-file signature)) - (pgg-process-when-success - (goto-char (point-min)) - (let ((case-fold-search t)) - (while (re-search-forward "^warning: " nil t) - (delete-region (match-beginning 0) - (progn (beginning-of-line 2) (point))))) - (goto-char (point-min)) - (when (re-search-forward "^\\.$" nil t) - (delete-region (point-min) - (progn (beginning-of-line 2) - (point))))))) - -(defun pgg-pgp-insert-key () - "Insert public key at point." - (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id)) - (args - (list "+verbose=1" "+batchmode" "+language=us" "-kxaf" - (concat "\"" pgg-pgp-user-id "\"")))) - (pgg-pgp-process-region (point)(point) nil pgg-pgp-program args) - (insert-buffer-substring pgg-output-buffer))) - -(defun pgg-pgp-snarf-keys-region (start end) - "Add all public keys in region between START and END to the keyring." - (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id)) - (key-file (pgg-make-temp-file "pgg")) - (args - (list "+verbose=1" "+batchmode" "+language=us" "-kaf" - key-file))) - (let ((coding-system-for-write 'raw-text-dos)) - (write-region start end key-file)) - (pgg-pgp-process-region start end nil pgg-pgp-program args) - (delete-file key-file) - (pgg-process-when-success nil))) - -(provide 'pgg-pgp) - -;;; arch-tag: 076b7801-37b2-49a6-97c3-218fdecde33c -;;; pgg-pgp.el ends here diff --git a/lisp/gnus/pgg-pgp5.el b/lisp/gnus/pgg-pgp5.el deleted file mode 100644 index ffe467ec044..00000000000 --- a/lisp/gnus/pgg-pgp5.el +++ /dev/null @@ -1,250 +0,0 @@ -;;; pgg-pgp5.el --- PGP 5.* support for PGG. - -;; Copyright (C) 1999, 2000, 2002, 2003, 2004, -;; 2005 Free Software Foundation, Inc. - -;; Author: Daiki Ueno <ueno@unixuser.org> -;; Created: 1999/11/02 -;; Keywords: PGP, OpenPGP - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Code: - -(eval-when-compile - (require 'cl) ; for pgg macros - (require 'pgg)) - -(defgroup pgg-pgp5 () - "PGP 5.* interface." - :group 'pgg) - -(defcustom pgg-pgp5-pgpe-program "pgpe" - "PGP 5.* 'pgpe' executable." - :group 'pgg-pgp5 - :type 'string) - -(defcustom pgg-pgp5-pgps-program "pgps" - "PGP 5.* 'pgps' executable." - :group 'pgg-pgp5 - :type 'string) - -(defcustom pgg-pgp5-pgpk-program "pgpk" - "PGP 5.* 'pgpk' executable." - :group 'pgg-pgp5 - :type 'string) - -(defcustom pgg-pgp5-pgpv-program "pgpv" - "PGP 5.* 'pgpv' executable." - :group 'pgg-pgp5 - :type 'string) - -(defcustom pgg-pgp5-shell-file-name "/bin/sh" - "File name to load inferior shells from. -Bourne shell or its equivalent \(not tcsh) is needed for \"2>\"." - :group 'pgg-pgp5 - :type 'string) - -(defcustom pgg-pgp5-shell-command-switch "-c" - "Switch used to have the shell execute its command line argument." - :group 'pgg-pgp5 - :type 'string) - -(defcustom pgg-pgp5-extra-args nil - "Extra arguments for every PGP 5.* invocation." - :group 'pgg-pgp5 - :type '(choice - (const :tag "None" nil) - (string :tag "Arguments"))) - -(defvar pgg-pgp5-user-id nil - "PGP 5.* ID of your default identity.") - -(defun pgg-pgp5-process-region (start end passphrase program args) - (let* ((errors-file-name (pgg-make-temp-file "pgg-errors")) - (args - (append args - pgg-pgp5-extra-args - (list (concat "2>" errors-file-name)))) - (shell-file-name pgg-pgp5-shell-file-name) - (shell-command-switch pgg-pgp5-shell-command-switch) - (process-environment process-environment) - (output-buffer pgg-output-buffer) - (errors-buffer pgg-errors-buffer) - (process-connection-type nil) - process status exit-status) - (with-current-buffer (get-buffer-create output-buffer) - (buffer-disable-undo) - (erase-buffer)) - (when passphrase - (setenv "PGPPASSFD" "0")) - (unwind-protect - (progn - (let ((coding-system-for-read 'binary) - (coding-system-for-write 'binary)) - (setq process - (apply #'funcall - #'start-process-shell-command "*PGP*" output-buffer - program args))) - (set-process-sentinel process #'ignore) - (when passphrase - (process-send-string process (concat passphrase "\n"))) - (process-send-region process start end) - (process-send-eof process) - (while (eq 'run (process-status process)) - (accept-process-output process 5)) - (setq status (process-status process) - exit-status (process-exit-status process)) - (delete-process process) - (with-current-buffer output-buffer - (pgg-convert-lbt-region (point-min)(point-max) 'LF) - - (if (memq status '(stop signal)) - (error "%s exited abnormally: '%s'" program exit-status)) - (if (= 127 exit-status) - (error "%s could not be found" program)) - - (set-buffer (get-buffer-create errors-buffer)) - (buffer-disable-undo) - (erase-buffer) - (insert-file-contents errors-file-name))) - (if (and process (eq 'run (process-status process))) - (interrupt-process process)) - (condition-case nil - (delete-file errors-file-name) - (file-error nil))))) - -(defun pgg-pgp5-lookup-key (string &optional type) - "Search keys associated with STRING." - (let ((args (list "+language=en" "-l" string))) - (with-current-buffer (get-buffer-create pgg-output-buffer) - (buffer-disable-undo) - (erase-buffer) - (apply #'call-process pgg-pgp5-pgpk-program nil t nil args) - (goto-char (point-min)) - (when (re-search-forward "^sec" nil t) - (substring - (nth 2 (split-string - (buffer-substring (match-end 0)(progn (end-of-line)(point))))) - 2))))) - -(defun pgg-pgp5-encrypt-region (start end recipients &optional sign) - "Encrypt the current region between START and END." - (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) - (args - `("+NoBatchInvalidKeys=off" "-fat" "+batchmode=1" - ,@(if recipients - (apply #'append - (mapcar (lambda (rcpt) - (list "-r" - (concat "\"" rcpt "\""))) - (append recipients - (if pgg-encrypt-for-me - (list pgg-pgp5-user-id))))))))) - (pgg-pgp5-process-region start end nil pgg-pgp5-pgpe-program args) - (pgg-process-when-success nil))) - -(defun pgg-pgp5-decrypt-region (start end) - "Decrypt the current region between START and END." - (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) - (passphrase - (pgg-read-passphrase - (format "PGP passphrase for %s: " pgg-pgp5-user-id) - (pgg-pgp5-lookup-key pgg-pgp5-user-id 'encrypt))) - (args - '("+verbose=1" "+batchmode=1" "+language=us" "-f"))) - (pgg-pgp5-process-region start end passphrase pgg-pgp5-pgpv-program args) - (pgg-process-when-success nil))) - -(defun pgg-pgp5-sign-region (start end &optional clearsign) - "Make detached signature from text between START and END." - (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) - (passphrase - (pgg-read-passphrase - (format "PGP passphrase for %s: " pgg-pgp5-user-id) - (pgg-pgp5-lookup-key pgg-pgp5-user-id 'sign))) - (args - (list (if clearsign "-fat" "-fbat") - "+verbose=1" "+language=us" "+batchmode=1" - "-u" pgg-pgp5-user-id))) - (pgg-pgp5-process-region start end passphrase pgg-pgp5-pgps-program args) - (pgg-process-when-success - (when (re-search-forward "^-+BEGIN PGP SIGNATURE" nil t);XXX - (let ((packet - (cdr (assq 2 (pgg-parse-armor-region - (progn (beginning-of-line 2) - (point)) - (point-max)))))) - (if pgg-cache-passphrase - (pgg-add-passphrase-cache - (cdr (assq 'key-identifier packet)) - passphrase))))))) - -(defun pgg-pgp5-verify-region (start end &optional signature) - "Verify region between START and END as the detached signature SIGNATURE." - (let ((orig-file (pgg-make-temp-file "pgg")) - (args '("+verbose=1" "+batchmode=1" "+language=us")) - (orig-mode (default-file-modes))) - (unwind-protect - (progn - (set-default-file-modes 448) - (let ((coding-system-for-write 'binary) - jka-compr-compression-info-list jam-zcat-filename-list) - (write-region start end orig-file))) - (set-default-file-modes orig-mode)) - (when (stringp signature) - (copy-file signature (setq signature (concat orig-file ".asc"))) - (setq args (append args (list signature)))) - (pgg-pgp5-process-region (point)(point) nil pgg-pgp5-pgpv-program args) - (delete-file orig-file) - (if signature (delete-file signature)) - (with-current-buffer pgg-errors-buffer - (goto-char (point-min)) - (if (re-search-forward "^Good signature" nil t) - (progn - (set-buffer pgg-output-buffer) - (insert-buffer-substring pgg-errors-buffer) - t) - nil)))) - -(defun pgg-pgp5-insert-key () - "Insert public key at point." - (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) - (args - (list "+verbose=1" "+batchmode=1" "+language=us" "-x" - (concat "\"" pgg-pgp5-user-id "\"")))) - (pgg-pgp5-process-region (point)(point) nil pgg-pgp5-pgpk-program args) - (insert-buffer-substring pgg-output-buffer))) - -(defun pgg-pgp5-snarf-keys-region (start end) - "Add all public keys in region between START and END to the keyring." - (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) - (key-file (pgg-make-temp-file "pgg")) - (args - (list "+verbose=1" "+batchmode=1" "+language=us" "-a" - key-file))) - (let ((coding-system-for-write 'raw-text-dos)) - (write-region start end key-file)) - (pgg-pgp5-process-region start end nil pgg-pgp5-pgpk-program args) - (delete-file key-file) - (pgg-process-when-success nil))) - -(provide 'pgg-pgp5) - -;;; arch-tag: 3dbd1073-6b3a-466c-9f55-5c587ffa6d7b -;;; pgg-pgp5.el ends here diff --git a/lisp/gnus/pgg.el b/lisp/gnus/pgg.el deleted file mode 100644 index af59833c6c0..00000000000 --- a/lisp/gnus/pgg.el +++ /dev/null @@ -1,453 +0,0 @@ -;;; pgg.el --- glue for the various PGP implementations. - -;; Copyright (C) 1999, 2000, 2002, 2003, 2004, -;; 2005 Free Software Foundation, Inc. - -;; Author: Daiki Ueno <ueno@unixuser.org> -;; Created: 1999/10/28 -;; Keywords: PGP - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;;; Code: - -(require 'pgg-def) -(require 'pgg-parse) -(autoload 'run-at-time "timer") - -;; Don't merge these two `eval-when-compile's. -(eval-when-compile - (require 'cl)) - -;;; @ utility functions -;;; - -(defun pgg-invoke (func scheme &rest args) - (progn - (require (intern (format "pgg-%s" scheme))) - (apply 'funcall (intern (format "pgg-%s-%s" scheme func)) args))) - -(put 'pgg-save-coding-system 'lisp-indent-function 2) - -(defmacro pgg-save-coding-system (start end &rest body) - `(if (interactive-p) - (let ((buffer (current-buffer))) - (with-temp-buffer - (let (buffer-undo-list) - (insert-buffer-substring buffer ,start ,end) - (encode-coding-region (point-min)(point-max) - buffer-file-coding-system) - (prog1 (save-excursion ,@body) - (push nil buffer-undo-list) - (ignore-errors (undo)))))) - (save-restriction - (narrow-to-region ,start ,end) - ,@body))) - -(defun pgg-temp-buffer-show-function (buffer) - (let ((window (or (get-buffer-window buffer 'visible) - (split-window-vertically)))) - (set-window-buffer window buffer) - (shrink-window-if-larger-than-buffer window))) - -(defun pgg-display-output-buffer (start end status) - (if status - (progn - (delete-region start end) - (insert-buffer-substring pgg-output-buffer) - (decode-coding-region start (point) buffer-file-coding-system)) - (let ((temp-buffer-show-function - (function pgg-temp-buffer-show-function))) - (with-output-to-temp-buffer pgg-echo-buffer - (set-buffer standard-output) - (insert-buffer-substring pgg-errors-buffer))))) - -(defvar pgg-passphrase-cache (make-vector 7 0)) - -(defun pgg-read-passphrase (prompt &optional key) - (or (and pgg-cache-passphrase - key (setq key (pgg-truncate-key-identifier key)) - (symbol-value (intern-soft key pgg-passphrase-cache))) - (read-passwd prompt))) - -(eval-when-compile - (defmacro pgg-run-at-time-1 (time repeat function args) - (when (featurep 'xemacs) - (if (condition-case nil - (let ((delete-itimer 'delete-itimer) - (itimer-driver-start 'itimer-driver-start) - (itimer-value 'itimer-value) - (start-itimer 'start-itimer)) - (unless (or (symbol-value 'itimer-process) - (symbol-value 'itimer-timer)) - (funcall itimer-driver-start)) - ;; Check whether there is a bug to which the difference of - ;; the present time and the time when the itimer driver was - ;; woken up is subtracted from the initial itimer value. - (let* ((inhibit-quit t) - (ctime (current-time)) - (itimer-timer-last-wakeup - (prog1 - ctime - (setcar ctime (1- (car ctime))))) - (itimer-list nil) - (itimer (funcall start-itimer "pgg-run-at-time" - 'ignore 5))) - (sleep-for 0.1) ;; Accept the timeout interrupt. - (prog1 - (> (funcall itimer-value itimer) 0) - (funcall delete-itimer itimer)))) - (error nil)) - `(let ((time ,time)) - (apply #'start-itimer "pgg-run-at-time" - ,function (if time (max time 1e-9) 1e-9) - ,repeat nil t ,args))) - `(let ((time ,time) - (itimers (list nil))) - (setcar - itimers - (apply #'start-itimer "pgg-run-at-time" - (lambda (itimers repeat function &rest args) - (let ((itimer (car itimers))) - (if repeat - (progn - (set-itimer-function - itimer - (lambda (itimer repeat function &rest args) - (set-itimer-restart itimer repeat) - (set-itimer-function itimer function) - (set-itimer-function-arguments itimer args) - (apply function args))) - (set-itimer-function-arguments - itimer - (append (list itimer repeat function) args))) - (set-itimer-function - itimer - (lambda (itimer function &rest args) - (delete-itimer itimer) - (apply function args))) - (set-itimer-function-arguments - itimer - (append (list itimer function) args))))) - 1e-9 (if time (max time 1e-9) 1e-9) - nil t itimers ,repeat ,function ,args)))))) - -(eval-and-compile - (if (featurep 'xemacs) - (defun pgg-run-at-time (time repeat function &rest args) - "Emulating function run as `run-at-time'. -TIME should be nil meaning now, or a number of seconds from now. -Return an itimer object which can be used in either `delete-itimer' -or `cancel-timer'." - (pgg-run-at-time-1 time repeat function args)) - (defalias 'pgg-run-at-time 'run-at-time))) - -(defun pgg-add-passphrase-cache (key passphrase) - (setq key (pgg-truncate-key-identifier key)) - (set (intern key pgg-passphrase-cache) - passphrase) - (pgg-run-at-time pgg-passphrase-cache-expiry nil - #'pgg-remove-passphrase-cache - key)) - -(defun pgg-remove-passphrase-cache (key) - (let ((passphrase (symbol-value (intern-soft key pgg-passphrase-cache)))) - (when passphrase - (fillarray passphrase ?_) - (unintern key pgg-passphrase-cache)))) - -(defmacro pgg-convert-lbt-region (start end lbt) - `(let ((pgg-conversion-end (set-marker (make-marker) ,end))) - (goto-char ,start) - (case ,lbt - (CRLF - (while (progn - (end-of-line) - (> (marker-position pgg-conversion-end) (point))) - (insert "\r") - (forward-line 1))) - (LF - (while (re-search-forward "\r$" pgg-conversion-end t) - (replace-match "")))))) - -(put 'pgg-as-lbt 'lisp-indent-function 3) - -(defmacro pgg-as-lbt (start end lbt &rest body) - `(let ((inhibit-read-only t) - buffer-read-only - buffer-undo-list) - (pgg-convert-lbt-region ,start ,end ,lbt) - (let ((,end (point))) - ,@body) - (push nil buffer-undo-list) - (ignore-errors (undo)))) - -(put 'pgg-process-when-success 'lisp-indent-function 0) - -(defmacro pgg-process-when-success (&rest body) - `(with-current-buffer pgg-output-buffer - (if (zerop (buffer-size)) nil ,@body t))) - -(defalias 'pgg-make-temp-file - (if (fboundp 'make-temp-file) - 'make-temp-file - (lambda (prefix &optional dir-flag) - (let ((file (expand-file-name - (make-temp-name prefix) - (if (fboundp 'temp-directory) - (temp-directory) - temporary-file-directory)))) - (if dir-flag - (make-directory file)) - file)))) - -;;; @ interface functions -;;; - -;;;###autoload -(defun pgg-encrypt-region (start end rcpts &optional sign) - "Encrypt the current region between START and END for RCPTS. -If optional argument SIGN is non-nil, do a combined sign and encrypt." - (interactive - (list (region-beginning)(region-end) - (split-string (read-string "Recipients: ") "[ \t,]+"))) - (let ((status - (pgg-save-coding-system start end - (pgg-invoke "encrypt-region" (or pgg-scheme pgg-default-scheme) - (point-min) (point-max) rcpts sign)))) - (when (interactive-p) - (pgg-display-output-buffer start end status)) - status)) - -;;;###autoload -(defun pgg-encrypt (rcpts &optional sign start end) - "Encrypt the current buffer for RCPTS. -If optional argument SIGN is non-nil, do a combined sign and encrypt. -If optional arguments START and END are specified, only encrypt within -the region." - (interactive (list (split-string (read-string "Recipients: ") "[ \t,]+"))) - (let* ((start (or start (point-min))) - (end (or end (point-max))) - (status (pgg-encrypt-region start end rcpts sign))) - (when (interactive-p) - (pgg-display-output-buffer start end status)) - status)) - -;;;###autoload -(defun pgg-decrypt-region (start end) - "Decrypt the current region between START and END." - (interactive "r") - (let* ((buf (current-buffer)) - (status - (pgg-save-coding-system start end - (pgg-invoke "decrypt-region" (or pgg-scheme pgg-default-scheme) - (point-min) (point-max))))) - (when (interactive-p) - (pgg-display-output-buffer start end status)) - status)) - -;;;###autoload -(defun pgg-decrypt (&optional start end) - "Decrypt the current buffer. -If optional arguments START and END are specified, only decrypt within -the region." - (interactive "") - (let* ((start (or start (point-min))) - (end (or end (point-max))) - (status (pgg-decrypt-region start end))) - (when (interactive-p) - (pgg-display-output-buffer start end status)) - status)) - -;;;###autoload -(defun pgg-sign-region (start end &optional cleartext) - "Make the signature from text between START and END. -If the optional 3rd argument CLEARTEXT is non-nil, it does not create -a detached signature. -If this function is called interactively, CLEARTEXT is enabled -and the the output is displayed." - (interactive "r") - (let ((status (pgg-save-coding-system start end - (pgg-invoke "sign-region" (or pgg-scheme pgg-default-scheme) - (point-min) (point-max) - (or (interactive-p) cleartext))))) - (when (interactive-p) - (pgg-display-output-buffer start end status)) - status)) - -;;;###autoload -(defun pgg-sign (&optional cleartext start end) - "Sign the current buffer. -If the optional argument CLEARTEXT is non-nil, it does not create a -detached signature. -If optional arguments START and END are specified, only sign data -within the region. -If this function is called interactively, CLEARTEXT is enabled -and the the output is displayed." - (interactive "") - (let* ((start (or start (point-min))) - (end (or end (point-max))) - (status (pgg-sign-region start end (or (interactive-p) cleartext)))) - (when (interactive-p) - (pgg-display-output-buffer start end status)) - status)) - -;;;###autoload -(defun pgg-verify-region (start end &optional signature fetch) - "Verify the current region between START and END. -If the optional 3rd argument SIGNATURE is non-nil, it is treated as -the detached signature of the current region. - -If the optional 4th argument FETCH is non-nil, we attempt to fetch the -signer's public key from `pgg-default-keyserver-address'." - (interactive "r") - (let* ((packet - (if (null signature) nil - (with-temp-buffer - (buffer-disable-undo) - (if (fboundp 'set-buffer-multibyte) - (set-buffer-multibyte nil)) - (insert-file-contents signature) - (cdr (assq 2 (pgg-decode-armor-region - (point-min)(point-max))))))) - (key (cdr (assq 'key-identifier packet))) - status keyserver) - (and (stringp key) - pgg-query-keyserver - (setq key (concat "0x" (pgg-truncate-key-identifier key))) - (null (pgg-lookup-key key)) - (or fetch (interactive-p)) - (y-or-n-p (format "Key %s not found; attempt to fetch? " key)) - (setq keyserver - (or (cdr (assq 'preferred-key-server packet)) - pgg-default-keyserver-address)) - (pgg-fetch-key keyserver key)) - (setq status - (pgg-save-coding-system start end - (pgg-invoke "verify-region" (or pgg-scheme pgg-default-scheme) - (point-min) (point-max) signature))) - (when (interactive-p) - (let ((temp-buffer-show-function - (function pgg-temp-buffer-show-function))) - (with-output-to-temp-buffer pgg-echo-buffer - (set-buffer standard-output) - (insert-buffer-substring (if status pgg-output-buffer - pgg-errors-buffer))))) - status)) - -;;;###autoload -(defun pgg-verify (&optional signature fetch start end) - "Verify the current buffer. -If the optional argument SIGNATURE is non-nil, it is treated as -the detached signature of the current region. -If the optional argument FETCH is non-nil, we attempt to fetch the -signer's public key from `pgg-default-keyserver-address'. -If optional arguments START and END are specified, only verify data -within the region." - (interactive "") - (let* ((start (or start (point-min))) - (end (or end (point-max))) - (status (pgg-verify-region start end signature fetch))) - (when (interactive-p) - (let ((temp-buffer-show-function - (function pgg-temp-buffer-show-function))) - (with-output-to-temp-buffer pgg-echo-buffer - (set-buffer standard-output) - (insert-buffer-substring (if status pgg-output-buffer - pgg-errors-buffer))))) - status)) - -;;;###autoload -(defun pgg-insert-key () - "Insert the ASCII armored public key." - (interactive) - (pgg-invoke "insert-key" (or pgg-scheme pgg-default-scheme))) - -;;;###autoload -(defun pgg-snarf-keys-region (start end) - "Import public keys in the current region between START and END." - (interactive "r") - (pgg-save-coding-system start end - (pgg-invoke "snarf-keys-region" (or pgg-scheme pgg-default-scheme) - start end))) - -;;;###autoload -(defun pgg-snarf-keys () - "Import public keys in the current buffer." - (interactive "") - (pgg-snarf-keys-region (point-min) (point-max))) - -(defun pgg-lookup-key (string &optional type) - (pgg-invoke "lookup-key" (or pgg-scheme pgg-default-scheme) string type)) - -(defvar pgg-insert-url-function (function pgg-insert-url-with-w3)) - -(defun pgg-insert-url-with-w3 (url) - (ignore-errors - (require 'url) - (let (buffer-file-name) - (url-insert-file-contents url)))) - -(defvar pgg-insert-url-extra-arguments nil) -(defvar pgg-insert-url-program nil) - -(defun pgg-insert-url-with-program (url) - (let ((args (copy-sequence pgg-insert-url-extra-arguments)) - process) - (insert - (with-temp-buffer - (setq process - (apply #'start-process " *PGG url*" (current-buffer) - pgg-insert-url-program (nconc args (list url)))) - (set-process-sentinel process #'ignore) - (while (eq 'run (process-status process)) - (accept-process-output process 5)) - (delete-process process) - (if (and process (eq 'run (process-status process))) - (interrupt-process process)) - (buffer-string))))) - -(defun pgg-fetch-key (keyserver key) - "Attempt to fetch a KEY from KEYSERVER for addition to PGP or GnuPG keyring." - (with-current-buffer (get-buffer-create pgg-output-buffer) - (buffer-disable-undo) - (erase-buffer) - (let ((proto (if (string-match "^[a-zA-Z\\+\\.\\\\-]+:" keyserver) - (substring keyserver 0 (1- (match-end 0)))))) - (save-excursion - (funcall pgg-insert-url-function - (if proto keyserver - (format "http://%s:11371/pks/lookup?op=get&search=%s" - keyserver key)))) - (when (re-search-forward "^-+BEGIN" nil 'last) - (delete-region (point-min) (match-beginning 0)) - (when (re-search-forward "^-+END" nil t) - (delete-region (progn (end-of-line) (point)) - (point-max))) - (insert "\n") - (with-temp-buffer - (insert-buffer-substring pgg-output-buffer) - (pgg-snarf-keys-region (point-min)(point-max))))))) - - -(provide 'pgg) - -;;; arch-tag: 9cc705dd-1e6a-4c90-8dce-c3561f9a2cf4 -;;; pgg.el ends here diff --git a/lisp/gnus/rfc2047.el b/lisp/gnus/rfc2047.el index 84c46e936a3..d03a25c4564 100644 --- a/lisp/gnus/rfc2047.el +++ b/lisp/gnus/rfc2047.el @@ -812,6 +812,85 @@ it, put the following line in your ~/.gnus.el file: (defvar rfc2047-quote-decoded-words-containing-tspecials nil "If non-nil, quote decoded words containing special characters.") +(defvar rfc2047-allow-incomplete-encoded-text t + "*Non-nil means allow incomplete encoded-text in successive encoded-words. +Dividing of encoded-text in the place other than character boundaries +violates RFC2047 section 5, while we have a capability to decode it. +If it is non-nil, the decoder will decode B- or Q-encoding in each +encoded-word, concatenate them, and decode it by charset. Otherwise, +the decoder will fully decode each encoded-word before concatenating +them.") + +(defun rfc2047-charset-to-coding-system (charset) + "Return coding-system corresponding to MIME CHARSET. +If your Emacs implementation can't decode CHARSET, return nil." + (when (stringp charset) + (setq charset (intern (downcase charset)))) + (when (or (not charset) + (eq 'gnus-all mail-parse-ignored-charsets) + (memq 'gnus-all mail-parse-ignored-charsets) + (memq charset mail-parse-ignored-charsets)) + (setq charset mail-parse-charset)) + (let ((cs (mm-coding-system-p (mm-charset-to-coding-system charset)))) + (cond ((eq cs 'ascii) + (setq cs (or (mm-charset-to-coding-system mail-parse-charset) + 'raw-text))) + (cs) + ((and charset + (listp mail-parse-ignored-charsets) + (memq 'gnus-unknown mail-parse-ignored-charsets)) + (setq cs (mm-charset-to-coding-system mail-parse-charset)))) + (if (eq cs 'ascii) + 'raw-text + cs))) + +(defun rfc2047-decode-encoded-words (words) + "Decode successive encoded-words in WORDS and return a decoded string. +Each element of WORDS looks like (CHARSET ENCODING ENCODED-TEXT +ENCODED-WORD)." + (let (word charset cs encoding text rest) + (while words + (setq word (pop words)) + (if (and (or (setq cs (rfc2047-charset-to-coding-system + (setq charset (car word)))) + (progn + (message "Unknown charset: %s" charset) + nil)) + (condition-case code + (cond ((char-equal ?B (nth 1 word)) + (setq text (base64-decode-string + (rfc2047-pad-base64 (nth 2 word))))) + ((char-equal ?Q (nth 1 word)) + (setq text (quoted-printable-decode-string + (mm-subst-char-in-string + ?_ ? (nth 2 word) t))))) + (error + (message "%s" (error-message-string code)) + nil))) + (if (and rfc2047-allow-incomplete-encoded-text + (eq cs (caar rest))) + ;; Concatenate text of which the charset is the same. + (setcdr (car rest) (concat (cdar rest) text)) + (push (cons cs text) rest)) + ;; Don't decode encoded-word. + (push (cons nil (nth 3 word)) rest))) + (while rest + (setq words (concat + (or (and (setq cs (caar rest)) + (condition-case code + (mm-decode-coding-string (cdar rest) cs) + (error + (message "%s" (error-message-string code)) + nil))) + (concat (when (cdr rest) " ") + (cdar rest) + (when (and words + (not (eq (string-to-char words) ? ))) + " "))) + words) + rest (cdr rest))) + words)) + ;; Fixme: This should decode in place, not cons intermediate strings. ;; Also check whether it needs to worry about delimiting fields like ;; encoding. @@ -826,32 +905,32 @@ it, put the following line in your ~/.gnus.el file: "Decode MIME-encoded words in region between START and END." (interactive "r") (let ((case-fold-search t) - b e) + (eword-regexp (eval-when-compile + ;; Ignore whitespace between encoded-words. + (concat "[\n\t ]*\\(" rfc2047-encoded-word-regexp + "\\)"))) + b e match words) (save-excursion (save-restriction (narrow-to-region start end) - (goto-char (point-min)) - ;; Remove whitespace between encoded words. - (while (re-search-forward - (eval-when-compile - (concat "\\(" rfc2047-encoded-word-regexp "\\)" - "\\(\n?[ \t]\\)+" - "\\(" rfc2047-encoded-word-regexp "\\)")) - nil t) - (delete-region (goto-char (match-end 1)) (match-beginning 7))) - ;; Decode the encoded words. - (setq b (goto-char (point-min))) - (while (re-search-forward rfc2047-encoded-word-regexp nil t) - (setq e (match-beginning 0)) - (insert (rfc2047-parse-and-decode - (prog1 - (match-string 0) - (delete-region e (match-end 0))))) - (while (looking-at rfc2047-encoded-word-regexp) - (insert (rfc2047-parse-and-decode - (prog1 - (match-string 0) - (delete-region (point) (match-end 0)))))) + (goto-char (setq b start)) + ;; Look for the encoded-words. + (while (setq match (re-search-forward eword-regexp nil t)) + (setq e (match-beginning 1) + end (match-end 0) + words nil) + (while match + (push (list (match-string 2) ;; charset + (char-after (match-beginning 4)) ;; encoding + (match-string 5) ;; encoded-text + (match-string 1)) ;; encoded-word + words) + ;; Look for the subsequent encoded-words. + (when (setq match (looking-at eword-regexp)) + (goto-char (setq end (match-end 0))))) + ;; Replace the encoded-words with the decoded one. + (delete-region e end) + (insert (rfc2047-decode-encoded-words (nreverse words))) (save-restriction (narrow-to-region e (point)) (goto-char e) @@ -957,21 +1036,6 @@ it, put the following line in your ~/.gnus.el file: (mm-decode-coding-string string mail-parse-charset)) (mm-string-as-multibyte string))))) -(defun rfc2047-parse-and-decode (word) - "Decode WORD and return it if it is an encoded word. -Return WORD if it is not not an encoded word or if the charset isn't -decodable." - (if (not (string-match rfc2047-encoded-word-regexp word)) - word - (or - (condition-case nil - (rfc2047-decode - (match-string 1 word) - (string-to-char (match-string 3 word)) - (match-string 4 word)) - (error word)) - word))) ; un-decodable - (defun rfc2047-pad-base64 (string) "Pad STRING to quartets." ;; Be more liberal to accept buggy base64 strings. If @@ -987,36 +1051,6 @@ decodable." (2 (concat string "==")) (3 (concat string "="))))) -(defun rfc2047-decode (charset encoding string) - "Decode STRING from the given MIME CHARSET in the given ENCODING. -Valid ENCODINGs are the characters \"B\" and \"Q\". -If your Emacs implementation can't decode CHARSET, return nil." - (if (stringp charset) - (setq charset (intern (downcase charset)))) - (if (or (not charset) - (eq 'gnus-all mail-parse-ignored-charsets) - (memq 'gnus-all mail-parse-ignored-charsets) - (memq charset mail-parse-ignored-charsets)) - (setq charset mail-parse-charset)) - (let ((cs (mm-charset-to-coding-system charset))) - (if (and (not cs) charset - (listp mail-parse-ignored-charsets) - (memq 'gnus-unknown mail-parse-ignored-charsets)) - (setq cs (mm-charset-to-coding-system mail-parse-charset))) - (when cs - (when (eq cs 'ascii) - (setq cs (or mail-parse-charset 'raw-text))) - (mm-decode-coding-string - (cond - ((char-equal ?B encoding) - (base64-decode-string - (rfc2047-pad-base64 string))) - ((char-equal ?Q encoding) - (quoted-printable-decode-string - (mm-subst-char-in-string ?_ ? string t))) - (t (error "Invalid encoding: %c" encoding))) - cs)))) - (provide 'rfc2047) ;;; arch-tag: a07fe3d4-22b5-4c4a-bd89-b1f82d5d36f6 |