From: yamaoka Date: Fri, 15 Oct 2004 21:59:00 +0000 (+0000) Subject: Synch to No Gnus 200410151856. X-Git-Tag: t-gnus-6_17_4-quimby-~709 X-Git-Url: http://git.chise.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=bd3b2b0c6919a3ac5548e4000af7c504d6e1b6a3;p=elisp%2Fgnus.git- Synch to No Gnus 200410151856. --- diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 1c9114e..846d86b 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,29 @@ +2004-10-15 Teodor Zlatanov + + * spam.el (spam-backend-article-list-property) + (spam-backend-get-article-todo-list) + (spam-backend-put-article-todo-list, ) + (spam-summary-prepare-exit, spam-resolve-registrations-routine): + resolve registrations separately + (spam-register-routine): format comments + (spam-unregister-routine, spam-register-routine): always call with + specific-articles, no default list + (spam-summary-prepare-exit): use the spam-classifications function + + * netrc.el (autoload, netrc-parse): use encrypt.el instead of + gnus-encrypt.el + + * encrypt.el: copied from gnus-encrypt.el + + * gnus-encrypt.el: commented that it's obsolete + +2004-10-15 Reiner Steib + + * gnus-score.el (gnus-adaptive-pretty-print): New variable. + (gnus-score-save): Use it. + + * message.el (message-bury): Use `window-dedicated-p'. + 2004-10-15 Simon Josefsson * pop3.el (top-level): Don't require nnheader. diff --git a/lisp/encrypt.el b/lisp/encrypt.el new file mode 100644 index 0000000..8393823 --- /dev/null +++ b/lisp/encrypt.el @@ -0,0 +1,278 @@ +;;; encrypt.el --- file encryption routines +;; Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc. + +;; Author: Teodor Zlatanov +;; Created: 2003/01/24 +;; Keywords: files + +;; 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., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; This module addresses data encryption. Page breaks are used for +;;; grouping declarations and documentation relating to each +;;; particular aspect. + +;;; Code: + +;; autoload password +(eval-and-compile + (autoload 'password-read "password")) + +(defgroup encrypt nil + "File encryption configuration.") + +(defcustom encrypt-password-cache-expiry 200 + "Encryption password timeout. +When set, directly sets password-cache-expiry" + :type 'integer + :group 'encrypt + :set (lambda (symbol value) + (set symbol value) + (setq password-cache-expiry value))) + +(defcustom encrypt-file-alist nil + "List of file names or regexes matched with encryptions. +Format example: + '((\"beta\" + (gpg \"AES\")) + (\"/home/tzz/alpha\" + (encrypt-xor \"Semi-Secret\")))" + + :type '(repeat + (list :tag "Encryption entry" + (radio :tag "What to encrypt" + (file :tag "Filename") + (regexp :tag "Regular expression match")) + (radio :tag "How to encrypt it" + (list + :tag "GPG Encryption" + (const :tag "GPG Program" gpg) + (radio :tag "Choose a cipher" + (const :tag "3DES Encryption" "3DES") + (const :tag "CAST5 Encryption" "CAST5") + (const :tag "Blowfish Encryption" "BLOWFISH") + (const :tag "AES Encryption" "AES") + (const :tag "AES192 Encryption" "AES192") + (const :tag "AES256 Encryption" "AES256") + (const :tag "Twofish Encryption" "TWOFISH") + (string :tag "Cipher Name"))) + (list + :tag "Built-in simple XOR" + (const :tag "XOR Encryption" encrypt-xor) + (string :tag "XOR Cipher Value (seed value)"))))) + :group 'encrypt) + +;; TODO: now, load gencrypt.el and if successful, modify the +;; custom-type of encrypt-file-alist to add the gencrypt.el options + +;; (plist-get (symbol-plist 'encrypt-file-alist) 'custom-type) +;; then use plist-put + +(defcustom encrypt-gpg-path (executable-find "gpg") + "Path to the GPG program." + :type '(radio + (file :tag "Location of the GPG executable") + (const :tag "GPG is not installed" nil)) + :group 'encrypt) + +(defvar encrypt-temp-prefix "encrypt" + "Prefix for temporary filenames") + +(defun encrypt-find-model (filename) + "Given a filename, find a encrypt-file-alist entry" + (dolist (entry encrypt-file-alist) + (let ((match (nth 0 entry)) + (model (nth 1 entry))) + (when (or (eq match filename) + (string-match match filename)) + (return model))))) + +(defun encrypt-insert-file-contents (file &optional model) + "Decrypt FILE into the current buffer." + (interactive "fFile to insert: ") + (let* ((model (or model (encrypt-find-model file))) + (method (nth 0 model)) + (cipher (nth 1 model)) + (password-key (format "encrypt-password-%s-%s %s" + (symbol-name method) cipher file)) + (passphrase + (password-read-and-add + (format "%s password for cipher %s? " + (symbol-name method) cipher) + password-key)) + (buffer-file-coding-system 'binary) + (coding-system-for-read 'binary) + outdata) + + ;; note we only insert-file-contents if the method is known to be valid + (cond + ((eq method 'gpg) + (insert-file-contents file) + (setq outdata (encrypt-gpg-decode-buffer passphrase cipher))) + ((eq method 'encrypt-xor) + (insert-file-contents file) + (setq outdata (encrypt-xor-decode-buffer passphrase cipher)))) + + (if outdata + (progn + (gnus-message 9 "%s was decrypted with %s (cipher %s)" + file (symbol-name method) cipher) + (delete-region (point-min) (point-max)) + (goto-char (point-min)) + (insert outdata)) + ;; the decryption failed, alas + (password-cache-remove password-key) + (gnus-error 5 "%s was NOT decrypted with %s (cipher %s)" + file (symbol-name method) cipher)))) + +(defun encrypt-get-file-contents (file &optional model) + "Decrypt FILE and return the contents." + (interactive "fFile to decrypt: ") + (with-temp-buffer + (encrypt-insert-file-contents file model) + (buffer-string))) + +(defun encrypt-put-file-contents (file data &optional model) + "Encrypt the DATA to FILE, then continue normally." + (with-temp-buffer + (insert data) + (encrypt-write-file-contents file model))) + +(defun encrypt-write-file-contents (file &optional model) + "Encrypt the current buffer to FILE, then continue normally." + (interactive "fFile to write: ") + (let* ((model (or model (encrypt-find-model file))) + (method (nth 0 model)) + (cipher (nth 1 model)) + (password-key (format "encrypt-password-%s-%s %s" + (symbol-name method) cipher file)) + (passphrase + (password-read + (format "%s password for cipher %s? " + (symbol-name method) cipher) + password-key)) + outdata) + + (cond + ((eq method 'gpg) + (setq outdata (encrypt-gpg-encode-buffer passphrase cipher))) + ((eq method 'encrypt-xor) + (setq outdata (encrypt-xor-encode-buffer passphrase cipher)))) + + (if outdata + (progn + (gnus-message 9 "%s was encrypted with %s (cipher %s)" + file (symbol-name method) cipher) + (delete-region (point-min) (point-max)) + (goto-char (point-min)) + (insert outdata) + ;; do not confirm overwrites + (write-file file nil)) + ;; the decryption failed, alas + (password-cache-remove password-key) + (gnus-error 5 "%s was NOT encrypted with %s (cipher %s)" + file (symbol-name method) cipher)))) + +(defun encrypt-xor-encode-buffer (passphrase cipher) + (encrypt-xor-process-buffer passphrase cipher t)) + +(defun encrypt-xor-decode-buffer (passphrase cipher) + (encrypt-xor-process-buffer passphrase cipher nil)) + +(defun encrypt-xor-process-buffer (passphrase + cipher + &optional encode) + "Given PASSPHRASE, xor-encode or decode the contents of the current buffer." + (let* ((bs (buffer-substring-no-properties (point-min) (point-max))) + ;; passphrase-sum is a simple additive checksum of the + ;; passphrase and the cipher + (passphrase-sum + (when (stringp passphrase) + (apply '+ (append cipher passphrase nil)))) + new-list) + + (with-temp-buffer + (if encode + (progn + (dolist (x (append bs nil)) + (setq new-list (cons (logxor x passphrase-sum) new-list))) + + (dolist (x new-list) + (insert (format "%d " x)))) + (progn + (setq new-list (reverse (split-string bs))) + (dolist (x new-list) + (setq x (string-to-int x)) + (insert (format "%c" (logxor x passphrase-sum)))))) + (buffer-substring-no-properties (point-min) (point-max))))) + +(defun encrypt-gpg-encode-buffer (passphrase cipher) + (encrypt-gpg-process-buffer passphrase cipher t)) + +(defun encrypt-gpg-decode-buffer (passphrase cipher) + (encrypt-gpg-process-buffer passphrase cipher nil)) + +(defun encrypt-gpg-process-buffer (passphrase + cipher + &optional encode) + "With PASSPHRASE, use GPG to encode or decode the current buffer." + (let* ((program encrypt-gpg-path) + (input (buffer-substring-no-properties (point-min) (point-max))) + (temp-maker (if (fboundp 'make-temp-file) + 'make-temp-file + 'make-temp-name)) + (temp-file (funcall temp-maker encrypt-temp-prefix)) + (default-enable-multibyte-characters nil) + (args `("--cipher-algo" ,cipher + "--status-fd" "2" + "--logger-fd" "2" + "--passphrase-fd" "0" + "--no-tty")) + exit-status exit-data) + + (when encode + (setq args + (append args + '("--symmetric" + "--armor")))) + + (if program + (with-temp-buffer + (when passphrase + (insert passphrase "\n")) + (insert input) + (setq exit-status + (apply #'call-process-region (point-min) (point-max) program + t `(t ,temp-file) nil args)) + (if (equal exit-status 0) + (setq exit-data + (buffer-substring-no-properties (point-min) (point-max))) + (with-temp-buffer + (when (file-exists-p temp-file) + (insert-file-contents temp-file)) + (gnus-error 5 (format "%s exited abnormally: '%s' [%s]" + program exit-status (buffer-string))))) + (delete-file temp-file)) + (gnus-error 5 "GPG is not installed.")) + exit-data)) + +(provide 'encrypt) +;;; encrypt.el ends here + +;; arch-tag: d907e4f1-71b5-42b1-a180-fc7b84ff0648 diff --git a/lisp/gnus-encrypt.el b/lisp/gnus-encrypt.el index 56dc3ff..e60008f 100644 --- a/lisp/gnus-encrypt.el +++ b/lisp/gnus-encrypt.el @@ -1,4 +1,4 @@ -;;; gnus-encrypt.el --- file encryption routines for Gnus +;;; gnus-encrypt.el --- file encryption routines for Gnus, OBSOLETE (use encrypt.el instead) ;; Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc. ;; Author: Teodor Zlatanov diff --git a/lisp/gnus-score.el b/lisp/gnus-score.el index 3b30585..18af8c3 100644 --- a/lisp/gnus-score.el +++ b/lisp/gnus-score.el @@ -306,6 +306,13 @@ If this variable is nil, exact matching will always be used." :group 'gnus-score-files :type 'regexp) +(defcustom gnus-adaptive-pretty-print nil + "If non-nil, adaptive score files fill are pretty printed." + :group 'gnus-score-files + :group 'gnus-score-adapt + :version "22.0" ;; No Gnus + :type 'boolean) + (defcustom gnus-score-default-header nil "Default header when entering new scores. @@ -1439,12 +1446,13 @@ If FORMAT, also format the current score file." (setq score (setcdr entry (gnus-delete-alist 'touched score))) (erase-buffer) (let (emacs-lisp-mode-hook) - (if (string-match - (concat (regexp-quote gnus-adaptive-file-suffix) "$") - file) - ;; This is an adaptive score file, so we do not run - ;; it through `pp'. These files can get huge, and - ;; are not meant to be edited by human hands. + (if (and (not gnus-adaptive-pretty-print) + (string-match + (concat (regexp-quote gnus-adaptive-file-suffix) "$") + file)) + ;; This is an adaptive score file, so we do not run it through + ;; `pp' unless requested. These files can get huge, and are + ;; not meant to be edited by human hands. (gnus-prin1 score) ;; This is a normal score file, so we print it very ;; prettily. diff --git a/lisp/message.el b/lisp/message.el index 1ce5fdc..6bc1aa6 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -3819,8 +3819,7 @@ Instead, just auto-save the buffer and then bury it." "Bury this mail BUFFER." (let ((newbuf (other-buffer buffer))) (bury-buffer buffer) - (if (and (fboundp 'frame-parameters) - (cdr (assq 'dedicated (frame-parameters))) + (if (and (window-dedicated-p (selected-window)) (not (null (delq (selected-frame) (visible-frame-list))))) (delete-frame (selected-frame)) (switch-to-buffer newbuf)))) diff --git a/lisp/netrc.el b/lisp/netrc.el index a4ca0f0..0d59125 100644 --- a/lisp/netrc.el +++ b/lisp/netrc.el @@ -34,10 +34,10 @@ ;;; .netrc and .authinfo rc parsing ;;; -;; autoload gnus-encrypt +;; autoload encrypt (eval-and-compile - (autoload 'gnus-encrypt-find-model "gnus-encrypt") - (autoload 'gnus-encrypt-insert-file-contents "gnus-encrypt")) + (autoload 'encrypt-find-model "encrypt") + (autoload 'encrypt-insert-file-contents "encrypt")) (defgroup netrc nil "Netrc configuration.") @@ -53,11 +53,11 @@ (let ((tokens '("machine" "default" "login" "password" "account" "macdef" "force" "port")) - (encryption-model (gnus-encrypt-find-model file)) + (encryption-model (encrypt-find-model file)) alist elem result pair) (if encryption-model - (gnus-encrypt-insert-file-contents file encryption-model) + (encrypt-insert-file-contents file encryption-model) (insert-file-contents file)) (goto-char (point-min)) diff --git a/lisp/spam.el b/lisp/spam.el index 6e0d9a4..d8e8f80 100644 --- a/lisp/spam.el +++ b/lisp/spam.el @@ -877,6 +877,32 @@ CLASSIFICATION is 'ham or 'spam." classification type))) +(defun spam-backend-article-list-property (classification + &optional unregister) + "Property name of article list with CLASSIFICATION and UNREGISTER." + (let* ((r (if unregister "unregister" "register")) + (prop (format "%s-%s" classification r))) + prop)) + +(defun spam-backend-get-article-todo-list (backend + classification + &optional unregister) + "Get the articles to be processed for BACKEND and CLASSIFICATION. +With UNREGISTER, get articles to be unregistered. +This is a temporary storage function - nothing here persists." + (get + backend + (intern (spam-backend-article-list-property classification unregister)))) + +(defun spam-backend-put-article-todo-list (backend classification list &optional unregister) + "Set the LIST of articles to be processed for BACKEND and CLASSIFICATION. +With UNREGISTER, set articles to be unregistered. +This is a temporary storage function - nothing here persists." + (put + backend + (intern (spam-backend-article-list-property classification unregister)) + list)) + (defun spam-backend-ham-registration-function (backend) "Get the ham registration function for BACKEND." (get backend 'hrf)) @@ -1290,27 +1316,26 @@ addition to the set values for the group." ;; call spam-register-routine with specific articles to unregister, ;; when there are articles to unregister and the check is enabled (when (and unregister-list (symbol-value backend)) - (spam-unregister-routine - classification - backend - unregister-list)))))) + (spam-backend-put-article-todo-list backend + classification + unregister-list + t)))))) ;; do the non-moving backends first, then the moving ones (dolist (backend-type '(non-mover mover)) - (dolist (classification '(spam ham)) + (dolist (classification (spam-classifications)) (dolist (backend (spam-backend-list backend-type)) (when (spam-group-processor-p gnus-newsgroup-name backend classification) - (let ((num (spam-register-routine classification backend))) - (when (> num 0) - (gnus-message - 6 - "%d %s messages were processed by backend %s." - num - classification - backend))))))) + (spam-backend-put-article-todo-list backend + classification + (spam-list-articles + gnus-newsgroup-articles + classification)))))) + + (spam-resolve-registrations-routine) ; do the registrations now ;; we mark all the leftover spam articles as expired at the end (dolist (article (spam-list-articles @@ -1657,15 +1682,70 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." ;;{{{ registration/unregistration functions +(defun spam-resolve-registrations-routine () + "Go through the backends and register or unregister articles as needed." + (dolist (backend-type '(non-mover mover)) + (dolist (classification (spam-classifications)) + (dolist (backend (spam-backend-list backend-type)) + (let ((rlist (spam-backend-get-article-todo-list + backend classification)) + (ulist (spam-backend-get-article-todo-list + backend classification t)) + (delcount 0)) + + ;; clear the old lists right away + (spam-backend-put-article-todo-list backend + classification + nil + nil) + (spam-backend-put-article-todo-list backend + classification + nil + t) + + ;; eliminate duplicates + (dolist (article ulist) + (when (assq article rlist) + (incf delcount) + (setq rlist (delq article rlist)))) + + (unless (zerop delcount) + (gnus-message + 9 + "%d messages were saved the trouble of unregistering and then registering" + delcount)) + + ;; unregister articles + (unless (zerop (length ulist)) + (let ((num (spam-unregister-routine classification backend ulist))) + (when (> num 0) + (gnus-message + 6 + "%d %s messages were unregistered by backend %s." + num + classification + backend)))) + + ;; register articles + (unless (zerop (length rlist)) + (let ((num (spam-register-routine classification backend rlist))) + (when (> num 0) + (gnus-message + 6 + "%d %s messages were registered by backend %s." + num + classification + backend))))))))) + (defun spam-unregister-routine (classification - backend - &optional specific-articles) - (spam-register-routine classification backend t specific-articles)) + backend + specific-articles) + (spam-register-routine classification backend specific-articles t)) (defun spam-register-routine (classification - backend - &optional unregister - specific-articles) + backend + specific-articles + &optional unregister) (when (and (spam-classification-valid-p classification) (spam-backend-valid-p backend)) (let* ((register-function @@ -1695,7 +1775,8 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." classification backend) (funcall run-function articles) - ;; now log all the registrations (or undo them, depending on unregister) + ;; now log all the registrations (or undo them, depending on + ;; unregister) (dolist (article articles) (funcall log-function (spam-fetch-field-message-id-fast article) diff --git a/texi/ChangeLog b/texi/ChangeLog index 0f72cae..82162b5 100644 --- a/texi/ChangeLog +++ b/texi/ChangeLog @@ -1,3 +1,7 @@ +2004-10-15 Reiner Steib + + * gnus.texi (Adaptive Scoring): Added gnus-adaptive-pretty-print. + 2004-10-15 Katsumi Yamaoka * message.texi (Canceling News): Add how to set a password. diff --git a/texi/gnus-ja.texi b/texi/gnus-ja.texi index db6d834..ac34ce0 100644 --- a/texi/gnus-ja.texi +++ b/texi/gnus-ja.texi @@ -18935,6 +18935,11 @@ gnus にはこれらを全て自動的に --- まるで魔法でも使ったように作成 適応性スコア登録項目は、グループ名に @code{gnus-adaptive-file-suffix} を 付加した名前のファイルに入れられます。初期設定値は @file{ADAPT} です。 +@vindex gnus-adaptive-pretty-print +適応性スコアファイルは巨大になり得るし、人の手で編集されることは想定され +ていません。@code{gnus-adaptive-pretty-print} が @code{nil} (ディフォル +ト) であると、それらのファイルは人に読めるような形式では書かれません。 + @vindex gnus-score-exact-adapt-limit 適応性スコアを行うときは、部分文字列一致やファジーな一致を行った方が、お そらくほとんどの場合において良い結果が得られるでしょう。しかし、ヘッダー diff --git a/texi/gnus.texi b/texi/gnus.texi index 24f3797..a232f7b 100644 --- a/texi/gnus.texi +++ b/texi/gnus.texi @@ -19728,6 +19728,11 @@ The adaptive score entries will be put into a file where the name is the group name with @code{gnus-adaptive-file-suffix} appended. The default is @file{ADAPT}. +@vindex gnus-adaptive-pretty-print +Adaptive score files can get huge and are not meant to be edited by +human hands. If @code{gnus-adaptive-pretty-print} is @code{nil} (the +deafult) those files will not be written in a human readable way. + @vindex gnus-score-exact-adapt-limit When doing adaptive scoring, substring or fuzzy matching would probably give you the best results in most cases. However, if the header one