Synch with Oort Gnus.
authoryamaoka <yamaoka>
Fri, 9 Feb 2001 03:35:34 +0000 (03:35 +0000)
committeryamaoka <yamaoka>
Fri, 9 Feb 2001 03:35:34 +0000 (03:35 +0000)
contrib/canlock.el [new file with mode: 0644]
contrib/sha1.el [new file with mode: 0644]
lisp/ChangeLog
lisp/gnus-sum.el
lisp/gnus-xmas.el
lisp/message.el
lisp/nnmail.el

diff --git a/contrib/canlock.el b/contrib/canlock.el
new file mode 100644 (file)
index 0000000..474b834
--- /dev/null
@@ -0,0 +1,475 @@
+;;; canlock.el --- Functions for Cancel-Lock feature.
+;; Copyright (C) 1998,1999 Katsumi Yamaoka
+
+;; Author: Katsumi Yamaoka   <yamaoka@jpl.org>
+;;         Yuuichi Teranishi <teranisi@gohome.org>
+;;         Hideyuki SHIRAI   <shirai@rdmg.mgcs.mei.co.jp>
+;;         Hidekazu Nakamura <u90121@uis-inf.co.jp>
+;;         Ken'ichi Okada    <kokada@tamaru.kuee.kyoto-u.ac.jp>
+;;         Shuhei KOBAYASHI  <shuhei@aqua.ocn.ne.jp>
+;; Created: 1998-11-24
+;; Revised: 1999-06-14
+;; Keywords: news, cancel-lock, hmac, sha1, rfc2104
+
+;; This program 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.
+
+;; This program 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 this program; if not, write to the Free Software
+;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+;; USA.
+
+;;; Commentary:
+
+;; This library is based on draft-ietf-usefor-cancel-lock-01.txt,
+;; released on 1998-11-03.
+
+;;; Code:
+
+(defconst canlock-version "0.6")
+
+(eval-when-compile (require 'cl))
+(require 'custom)
+(require 'mail-utils)
+
+(autoload 'sha1-encode-binary "sha1")
+(autoload 'base64-encode "base64")
+
+(defgroup canlock nil
+  "Cancel-Lock feature."
+  :prefix "canlock-"
+  :group 'applications)
+
+(defcustom canlock-base64-encode-function 'base64-encode-string
+  "*Function called to encode string to base64."
+  :type '(radio (function-item base64-encode-string)
+               (function-item base64-encode)
+               (function-item canlock-base64-encode-string-with-mmencode)
+               (function :tag "Other"))
+  :group 'canlock)
+
+(defcustom canlock-mmencode-program "mmencode"
+  "*Name of mmencode program."
+  :type 'string
+  :group 'canlock)
+
+(defcustom canlock-mmencode-args-for-encoding nil
+  "*Arguments passed to mmencode program for encoding."
+  :type 'sexp
+  :group 'canlock)
+
+(defcustom canlock-sha1-function 'sha1-encode-binary
+  "*Function called to make a SHA1 digest from a message (string)."
+  :type '(radio (function-item sha1-encode-binary)
+               (function-item canlock-sha1-with-ssleay)
+               (function :tag "Other"))
+  :group 'canlock)
+
+(defcustom canlock-sha1-function-for-verify canlock-sha1-function
+  "*Function called to make a SHA1 digest for verifying."
+  :type '(radio (function-item sha1-encode-binary)
+               (function-item canlock-sha1-with-ssleay)
+               (function :tag "Other"))
+  :group 'canlock)
+
+(defcustom canlock-ssleay-program "ssleay"
+  "*Name of SSLeay program."
+  :type 'string
+  :group 'canlock)
+
+(defcustom canlock-ssleay-args '("sha1")
+  "*Arguments passed to SSLeay program."
+  :type 'sexp
+  :group 'canlock)
+
+(defcustom canlock-ignore-errors nil
+  "*If non-nil, ignore any error signals."
+  :type 'boolean
+  :group 'canlock)
+
+(defcustom canlock-load-hook nil
+  "*Hook to be run after the canlock package has been loaded."
+  :type 'hook
+  :group 'canlock)
+
+;;; Internal variables.
+
+(defvar canlock-password nil
+  "*Password to use when signing a Cancel-Lock or a Cancel-Key header.")
+
+(defvar canlock-password-for-verify canlock-password
+  "*Password to use when verifying a Cancel-Lock or a Cancel-Key header.")
+
+(defvar canlock-force-insert-header nil
+  "*If non-nil, insert a Cancel-Lock or a Cancel-Key header even though the
+buffer does not contain a news message.")
+
+;;; Functions.
+
+(defun canlock-base64-encode-string-with-mmencode (string)
+  "Encode string to base64 with mmencode."
+  (with-temp-buffer
+    (let ((coding-system-for-read 'raw-text)
+         (coding-system-for-write 'binary)
+         ;; For Mule 2 with APEL 9.12 or later.
+         (default-process-coding-system '(raw-text . binary))
+         mc-flag program-coding-system-alist)
+      (insert string)
+      (apply 'call-process-region (point-min) (point-max)
+            canlock-mmencode-program t t nil
+            canlock-mmencode-args-for-encoding)
+      (goto-char (point-max))
+      (skip-chars-backward "\n")
+      (buffer-substring (point-min) (point)))))
+
+(defun canlock-hex-string-to-int (string)
+  "Convert hexadecimal string to integer."
+  (let ((integer 0))
+    (mapcar
+     (lambda (hex)
+       (setq integer (+ (* 16 integer)
+                       (logand hex 15)
+                       (* (lsh hex -6) 9))))
+     string)
+    integer))
+
+(defun canlock-sha1-with-ssleay (message)
+  "Make a SHA1 digest from a specified message (string) with SSLeay."
+  (with-temp-buffer
+    (let ((coding-system-for-read 'binary)
+         (coding-system-for-write 'binary)
+         ;; For Mule 2 with APEL 9.12 or later.
+         (default-process-coding-system '(binary . binary))
+         mc-flag program-coding-system-alist
+         (case-fold-search t))
+      (insert message)
+      (apply 'call-process-region (point-min) (point-max)
+            canlock-ssleay-program t t nil canlock-ssleay-args)
+      (goto-char (point-min))
+      (while (re-search-forward "[0-9A-F][0-9A-F]" nil t)
+       (goto-char (match-beginning 0))
+       (insert-char (canlock-hex-string-to-int (match-string 0)) 1)
+       (delete-char 2))
+      (buffer-substring (point-min) (point)))))
+
+(defvar canlock-read-passwd nil)
+(defun canlock-read-passwd (prompt &rest args)
+  "Read a password using PROMPT.
+If ARGS, PROMPT is used as an argument to `format'."
+  (let ((prompt
+        (if args
+            (apply 'format prompt args)
+          prompt)))
+    (unless canlock-read-passwd
+      (if (or (fboundp 'read-passwd) (load "passwd" t))
+         (setq canlock-read-passwd 'read-passwd)
+       (unless (fboundp 'ange-ftp-read-passwd)
+         (autoload 'ange-ftp-read-passwd "ange-ftp"))
+       (setq canlock-read-passwd 'ange-ftp-read-passwd)))
+    (funcall canlock-read-passwd prompt)))
+
+(defun canlock-make-cancel-key (message-id password)
+  "Make a Cancel-Key header."
+  (cond ((> (length password) 20)
+        (setq password (funcall canlock-sha1-function password)))
+       ((< (length password) 20)
+        (setq password (concat
+                        password
+                        (make-string (- 20 (length password)) 0)))))
+  (setq password (concat password (make-string 44 0)))
+  (let ((ipad (mapconcat (lambda (char)
+                          (char-to-string (logxor 54 char)))
+                        password ""))
+       (opad (mapconcat (lambda (char)
+                          (char-to-string (logxor 92 char)))
+                        password "")))
+    (funcall canlock-base64-encode-function
+            (funcall canlock-sha1-function
+                     (concat
+                      opad
+                      (funcall canlock-sha1-function
+                               (concat ipad message-id)))))))
+
+(defun canlock-narrow-to-header ()
+  "Narrow to the message header."
+  (let (case-fold-search)
+    (narrow-to-region
+     (goto-char (point-min))
+     (goto-char (if (re-search-forward
+                    (format "^$\\|^%s$"
+                            (regexp-quote mail-header-separator))
+                    nil t)
+                   (match-beginning 0)
+                 (point-max))))))
+
+(defun canlock-delete-headers ()
+  "Delete Canlock headers if they already exist.
+The buffer is expected to be narrowed to just the headers of the message."
+  (let ((case-fold-search t))
+    (goto-char (point-min))
+    (while (re-search-forward "^Cancel-\\(Key\\|Lock\\):" nil t)
+      (delete-region (match-beginning 0)
+                    (if (re-search-forward "^[^\t ]" nil t)
+                        (goto-char (match-beginning 0))
+                      (point-max))))))
+
+(defun canlock-fetch-fields (&optional key)
+  "Return the list of values of Cancel-Lock field.
+If the optional arg KEY is non-nil, Cancel-Key field will be fetched.
+The buffer is expected to be narrowed to just the headers of the message."
+  (let ((feild (mail-fetch-field (if key "Cancel-Key" "Cancel-Lock")))
+       (case-fold-search t))
+    (when feild
+      (mapcar (lambda (str)
+               (string-match "^sha1:" str)
+               (substring str (match-end 0)))
+             (split-string feild "[\t\n\r ,]+")))))
+
+(defun canlock-fetch-id-for-key ()
+  "Return the Message-ID for Cancel-Key.
+The buffer is expected to be narrowed to just the headers of the message."
+  (let ((cancel (mail-fetch-field "Control")))
+    (if cancel
+       (progn
+         (string-match "^cancel[\t ]+\\(<[^\t\n @<>]+@[^\t\n @<>]+>\\)"
+                       cancel)
+         (match-string 1 cancel))
+      (or (mail-fetch-field "Supersedes")
+         (mail-fetch-field "Replaces")))))
+
+;;;###autoload
+(defun canlock-insert-header (&optional id-for-key id-for-lock password)
+  "Insert a Cancel-Key and/or a Cancel-Lock header if possible."
+  (let (news control key-for-key key-for-lock)
+    (save-excursion
+      (save-restriction
+       (canlock-narrow-to-header)
+       (when (setq news (or canlock-force-insert-header
+                            (mail-fetch-field "Newsgroups")))
+         (unless id-for-key
+           (setq id-for-key (canlock-fetch-id-for-key)))
+         (if (and (setq control (mail-fetch-field "Control"))
+                  (string-match
+                   "^cancel[\t ]+\\(<[^\t\n @<>]+@[^\t\n @<>]+>\\)"
+                   control))
+             (setq id-for-lock nil)
+           (unless id-for-lock
+             (setq id-for-lock (mail-fetch-field "Message-ID"))))
+         (canlock-delete-headers)
+         (goto-char (point-max))))
+      (when news
+       (if (not (or id-for-key id-for-lock))
+           (message "There are no Message-ID(s).")
+         (unless password
+           (setq password (or canlock-password
+                              (canlock-read-passwd
+                               "Password for Canlock: "))))
+         (if (or (not (stringp password)) (zerop (length password)))
+             (message "Password for Canlock is bad.")
+           (setq key-for-key (when id-for-key
+                               (canlock-make-cancel-key
+                                id-for-key password))
+                 key-for-lock (when id-for-lock
+                                (canlock-make-cancel-key
+                                 id-for-lock password)))
+           (if (not (or key-for-key key-for-lock))
+               (message "Couldn't insert Canlock header.")
+             (when key-for-key
+               (insert "Cancel-Key: sha1:" key-for-key "\n"))
+             (when key-for-lock
+               (insert "Cancel-Lock: sha1:"
+                       (funcall canlock-base64-encode-function
+                                (funcall canlock-sha1-function
+                                         key-for-lock))
+                       "\n")))))))))
+
+;;;###autoload
+(defun canlock-verify (&optional buffer)
+  "Verify Cancel-Lock or Cancel-Key. If failed, returns non-nil or signals
+an error if `canlock-ignore-errors' is nil.  If the optional arg BUFFER
+is not specified, it runs in place."
+  (interactive)
+  (let ((canlock-sha1-function (or canlock-sha1-function-for-verify
+                                  canlock-sha1-function))
+       keys locks errmsg id-for-key id-for-lock password
+       key-for-key key-for-lock match)
+    (save-excursion
+      (when buffer
+       (set-buffer buffer))
+      (save-restriction
+       (widen)
+       (canlock-narrow-to-header)
+       (setq keys (canlock-fetch-fields 'key)
+             locks (canlock-fetch-fields))
+       (if (not (or keys locks))
+           (setq errmsg
+                 "There are neither Cancel-Lock nor Cancel-Key fields.")
+         (setq id-for-key (canlock-fetch-id-for-key)
+               id-for-lock (mail-fetch-field "Message-ID"))
+         (or id-for-key id-for-lock
+             (setq errmsg "There are no Message-ID(s).")))))
+
+    (if errmsg
+       (if canlock-ignore-errors
+           errmsg
+         (error "%s" errmsg))
+
+      (setq password (or canlock-password-for-verify
+                        (canlock-read-passwd "Password for Canlock: ")))
+      (if (or (not (stringp password)) (zerop (length password)))
+         (progn
+           (setq errmsg "Password for Canlock is bad.")
+           (if canlock-ignore-errors
+               errmsg
+             (error "%s" errmsg)))
+
+       (when keys
+         (when id-for-key
+           (setq key-for-key (canlock-make-cancel-key id-for-key password))
+           (while (and keys (not match))
+             (setq match (string-equal key-for-key (pop keys)))))
+         (setq keys (if match "good" "bad")))
+       (setq match nil)
+
+       (when locks
+         (when id-for-lock
+           (setq key-for-lock
+                 (funcall canlock-base64-encode-function
+                          (funcall canlock-sha1-function
+                                   (canlock-make-cancel-key
+                                    id-for-lock password))))
+           (when (and locks (not match))
+             (setq match (string-equal key-for-lock (pop locks)))))
+         (setq locks (if match "good" "bad")))
+
+       (prog1
+           (when (member "bad" (list keys locks))
+             "bad")
+         (cond ((and keys locks)
+                (message "Cancel-Key is %s, Cancel-Lock is %s." keys locks))
+               (locks
+                (message "Cancel-Lock is %s." locks))
+               (keys
+                (message "Cancel-Key is %s." keys))))))))
+
+;; Avoid byte compile warnings.
+(defvar gnus-show-all-headers)
+(defvar gnus-original-article-buffer)
+(defvar mh-show-buffer)
+(defvar vm-mail-buffer)
+(defvar vm-message-pointer)
+(defvar cmail-current-folder)
+(defvar rmail-buffer)
+
+;;;###autoload
+(defun gnus-summary-canlock-verify ()
+  "Run `canlock-verify' from gnus summary buffer."
+  (interactive)
+  (gnus-summary-select-article gnus-show-all-headers)
+  (canlock-verify gnus-original-article-buffer))
+
+;;;###autoload
+(defun wl-summary-canlock-verify ()
+  "Run `canlock-verify' from Wanderlust summary buffer."
+  (interactive)
+  (wl-summary-set-message-buffer-or-redisplay)
+  (canlock-verify (wl-message-get-original-buffer)))
+
+(eval-when-compile
+  (if (or (featurep 'use-mew-1.94b20-or-later)
+         (and (fboundp 'function-max-args)
+              (or (fboundp 'mew-summary-display)
+                  (load "mew-summary" t))
+              (eq 2 (function-max-args 'mew-summary-display))))
+      (progn
+       (defmacro canlock-mew-summary-display ()
+         '(mew-summary-display t))
+       (message "Use mew-1.94b20 or later."))
+    (defmacro canlock-mew-summary-display ()
+      '(condition-case nil
+          (mew-summary-display)
+        (wrong-number-of-arguments
+         (mew-summary-display t))))
+    ))
+
+;;;###autoload
+(defun mew-summary-canlock-verify ()
+  "Run `canlock-verify' from Mew summary buffer."
+  (interactive)
+  (canlock-mew-summary-display)
+  (canlock-verify (mew-buffer-message)))
+
+;;;###autoload
+(defun mh-summary-canlock-verify ()
+  "Run `canlock-verify' from MH folder buffer."
+  (interactive)
+  (mh-header-display)
+  (canlock-verify mh-show-buffer))
+
+;;;###autoload
+(defun vm-summary-canlock-verify ()
+  "Run `canlock-verify' from VM summary buffer."
+  (interactive)
+  (vm-follow-summary-cursor)
+  (if (and vm-mail-buffer (buffer-name vm-mail-buffer))
+      (save-excursion
+       (set-buffer vm-mail-buffer)
+       (let* ((mp (car vm-message-pointer))
+              (header (save-restriction
+                        (widen)
+                        (buffer-substring
+                         (aref (aref mp 0) 0) (vm-text-of mp)))))
+         (with-temp-buffer
+           (insert header)
+           (canlock-verify))))
+    (or canlock-ignore-errors
+       (error "Folder buffer has been killed."))))
+
+;;;###autoload
+(defun cmail-summary-canlock-verify ()
+  "Run `canlock-verify' from cmail summary buffer."
+  (interactive)
+  (let* ((page (cmail-get-page-number-from-summary))
+        (header (save-excursion
+                  (set-buffer (cmail-folder-buffer cmail-current-folder))
+                  (cmail-n-page page)
+                  (buffer-substring (point)
+                                    (if (search-forward "\n\n" nil t)
+                                        (1- (point))
+                                      (point-max))))))
+    (with-temp-buffer
+      (insert header)
+      (canlock-verify))))
+
+;;;###autoload
+(defun rmail-summary-canlock-verify ()
+  "Run `canlock-verify' from RMAIL summary buffer."
+  (interactive)
+  (rmail-summary-rmail-update)
+  (let ((header (save-excursion
+                 (set-buffer rmail-buffer)
+                 (goto-char (point-min))
+                 (save-restriction
+                   (widen)
+                   (search-backward "\n\C-_\C-l\n") ;; ^_^L
+                   (re-search-forward "^[^\t\n ]+:")
+                   (buffer-substring
+                    (goto-char (match-beginning 0))
+                    (progn (search-forward "\n\n")
+                           (1- (point))))))))
+    (with-temp-buffer
+      (insert header)
+      (canlock-verify))))
+
+(provide 'canlock)
+
+(run-hooks 'canlock-load-hook)
+
+;;; canlock.el ends here
diff --git a/contrib/sha1.el b/contrib/sha1.el
new file mode 100644 (file)
index 0000000..f4706b8
--- /dev/null
@@ -0,0 +1,397 @@
+;;; sha1.el --- SHA1 Message Digest Algorithm.
+;; Copyright (C) 1998,1999 Keiichi Suzuki.
+
+;; Author: Keiichi Suzuki <kei-suzu@mail.wbs.ne.jp>
+;; Author: Katsumi Yamaoka <yamaoka@jpl.org>
+;; Created: 1998-12-25
+;; Revised: 1999-01-13
+;; Keywords: sha1, news, cancel-lock, hmac, rfc2104
+
+;; This program 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.
+
+;; This program 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.
+
+;;; A copy of the GNU General Public License can be obtained from this
+;;; program's author (send electronic mail to kyle@uunet.uu.net) or from
+;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
+;;; 02139, USA.
+
+;;; Commentary:
+
+;; This is a direct translation into Emacs LISP of the reference C
+;; implementation of the SHA1 message digest algorithm.
+
+;;; Usage:
+
+;; To compute the SHA1 message digest for a message M (represented as
+;; a string), call
+;; 
+;;   (sha1-encode M)
+;;
+;; which returns the message digest as a hexadecimal string of 20 bytes.
+;; If you need to supply the message in pieces M1, M2, ... Mn, then call
+;; 
+;;   (sha1-init)
+;;   (sha1-update M1)
+;;   (sha1-update M2)
+;;   ...
+;;   (sha1-update Mn)
+;;   (sha1-final)
+
+;;; Notes:
+
+;; The C algorithm uses 32-bit integers; because GNU Emacs
+;; implementations provide 28-bit integers (with 24-bit integers on
+;; versions prior to 19.29), the code represents a 32-bit integer as the
+;; cons of two 16-bit integers.  The most significant word is stored in
+;; the car and the least significant in the cdr.  The algorithm requires
+;; at least 19 bits of integer representation in order to represent the
+;; carry from a 16-bit addition. (see sha1-add())
+
+;;; Code:
+
+(defmacro sha1-f1 (x y z)
+  `(cons
+    (logior (logand (car ,x) (car ,y)) (logand (lognot (car ,x)) (car ,z)))
+    (logior (logand (cdr ,x) (cdr ,y)) (logand (lognot (cdr ,x)) (cdr ,z)))
+    ))
+
+(defmacro sha1-f2 (x y z)
+  `(cons
+    (logxor (car ,x) (car ,y) (car ,z))
+    (logxor (cdr ,x) (cdr ,y) (cdr ,z))
+    ))
+
+(defmacro sha1-f3 (x y z)
+  `(cons
+    (logior (logand (car ,x) (car ,y)) (logand (car ,x) (car ,z))
+           (logand (car ,y) (car ,z)))
+    (logior (logand (cdr ,x) (cdr ,y)) (logand (cdr ,x) (cdr ,z))
+           (logand (cdr ,y) (cdr ,z)))
+    ))
+
+(defmacro sha1-f4 (x y z)
+  `(cons
+    (logxor (car ,x) (car ,y) (car ,z))
+    (logxor (cdr ,x) (cdr ,y) (cdr ,z))
+    ))
+
+(defconst sha1-const1 '(23170 . 31129)
+  "SHA constants 1 \(0x5a827999\)")
+(defconst sha1-const2 '(28377 . 60321)
+  "SHA constants 2 \(0x6ed9eba1\)")
+(defconst sha1-const3 '(36635 . 48348)
+  "SHA constants 3 \(0x8f1bbcdc\)")
+(defconst sha1-const4 '(51810 . 49622)
+  "SHA constants 4 \(0xca62c1d6\)")
+
+(defvar sha1-digest (make-vector 5 nil))
+(defvar sha1-count-lo nil)
+(defvar sha1-count-hi nil)
+(defvar sha1-data nil)
+(defvar sha1-local nil)
+(defconst SHA1-BLOCKSIZE 64)
+
+(defun sha1-init ()
+  "Initialize the state of the SHA1 message digest routines."
+  (aset sha1-digest 0 (cons 26437 8961))
+  (aset sha1-digest 1 (cons 61389 43913))
+  (aset sha1-digest 2 (cons 39098 56574))
+  (aset sha1-digest 3 (cons  4146 21622))
+  (aset sha1-digest 4 (cons 50130 57840))
+  (setq sha1-count-lo (cons 0 0)
+       sha1-count-hi (cons 0 0)
+       sha1-local 0
+       sha1-data nil)
+  )
+
+(defmacro sha1-32-make (v)
+  "Return 32bits internal value from normal integer."
+  `(cons (lsh ,v -16) (logand 65535 ,v)))
+
+(defun sha1-add (to &rest vals)
+  "Set sum of all the arguments to the first one."
+  (let (val)
+    (while (setq val (car vals))
+      (setcar to (+ (car to) (car val)))
+      (setcdr to (+ (cdr to) (cdr val)))
+      (setq vals (cdr vals))
+      )
+    (setcar to (logand 65535 (+ (car to) (lsh (cdr to) -16))))
+    (setcdr to (logand 65535 (cdr to)))
+    to
+    ))
+
+(defun sha1-xor (to &rest vals)
+  "Set bitwise-exclusive-or of all the arguments to the first one."
+  (let (val)
+    (while (setq val (car vals))
+      (setcar to (logxor (car to) (car val)))
+      (setcdr to (logxor (cdr to) (cdr val)))
+      (setq vals (cdr vals)))
+    ))
+
+(defmacro sha1-rot (val c1 c2)
+  "Internal macro for sha1-rot-*."
+  `(cons
+    (logand 65535 (logior (lsh (car ,val) ,c1) (lsh (cdr ,val) ,c2)))
+    (logand 65535 (logior (lsh (cdr ,val) ,c1) (lsh (car ,val) ,c2)))
+    ))
+
+(defmacro sha1-rot-1 (val)
+  "Return VAL with its bits rotated left by 1."
+  `(sha1-rot ,val 1 -15)
+  )
+
+(defmacro sha1-rot-5 (val)
+  "Return VAL with its bits rotated left by 5."
+  `(sha1-rot ,val 5 -11)
+  )
+
+(defmacro sha1-rot-30 (val)
+  "Return VAL with its bits rotated left by 30."
+  `(sha1-rot ,val -2 14)
+  )
+
+(defun sha1-inc (to)
+  "Set TO pulus one to TO."
+  (setcdr to (1+ (cdr to)))
+  (when (> (cdr to) 65535)
+    (setcdr to (logand 65535 (cdr to)))
+    (setcar to (logand 65535 (1+ (car to))))))
+
+(defun sha1-lsh (to v count)
+  "Set TO with its bits shifted left by COUNT to TO."
+  (setcar to (logand 65535
+                    (logior (lsh (car v) count) (lsh (cdr v) (- count 16)))))
+  (setcdr to (logand 65535 (lsh (cdr v) count)))
+  to
+  )
+
+(defun sha1-rsh (to v count)
+  "Set TO with its bits shifted right by COUNT to TO."
+  (setq count (- 0 count))
+  (setcdr to (logand 65535
+                    (logior (lsh (cdr v) count) (lsh (car v) (- count 16)))))
+  (setcar to (logand 65535 (lsh (car v) count)))
+  to
+  )
+
+(defun sha1-< (v1 v2)
+  "Return t if firast argment is less then second argument."
+  (or (< (car v1) (car v2))
+      (and (eq (car v1) (car v2))
+          (< (cdr v1) (cdr v2))))
+  )
+
+(unless (fboundp 'string-as-unibyte)
+  (defsubst string-as-unibyte (string)
+    string)
+  )
+
+(defun sha1-update (bytes)
+  "Update the current SHA1 state with BYTES (an string of uni-bytes)."
+  (setq bytes (string-as-unibyte bytes))
+  (let* ((len (length bytes))
+        (len32 (sha1-32-make len))
+        (tmp32 (cons 0 0))
+        (top 0)
+        (clo (cons 0 0))
+        i done)
+    (sha1-add clo sha1-count-lo (sha1-lsh tmp32 len32 3))
+    (when (sha1-< clo sha1-count-lo)
+      (sha1-inc sha1-count-hi))
+    (setq sha1-count-lo clo)
+    (sha1-add sha1-count-hi (sha1-rsh tmp32 len32 29))
+    (when (> (length sha1-data) 0)
+      (setq i (- SHA1-BLOCKSIZE (length sha1-data)))
+      (when (> i len)
+       (setq i len))
+      (setq sha1-data (concat sha1-data (substring bytes 0 i)))
+      (setq len (- len i)
+           top i)
+      (if (eq (length sha1-data) SHA1-BLOCKSIZE)
+         (sha1-transform)
+       (setq done t)))
+    (when (not done)
+      (while (and (not done)
+                 (>= len SHA1-BLOCKSIZE))
+       (setq sha1-data (substring bytes top (+ top SHA1-BLOCKSIZE))
+             top (+ top SHA1-BLOCKSIZE)
+             len (- len SHA1-BLOCKSIZE))
+       (sha1-transform))
+      (setq sha1-data (substring bytes top (+ top len))))
+    ))
+
+(defmacro sha1-FA (n)
+  (let ((func (intern (format "sha1-f%d" n)))
+       (const (intern (format "sha1-const%d" n))))
+    `(setq T (sha1-add (cons 0 0) (sha1-rot-5 A) (,func B C D) E (aref W WIDX)
+                      ,const)
+          WIDX (1+ WIDX)
+          B (sha1-rot-30 B))))
+
+(defmacro sha1-FB (n)
+  (let ((func (intern (format "sha1-f%d" n)))
+       (const (intern (format "sha1-const%d" n))))
+    `(setq E (sha1-add (cons 0 0) (sha1-rot-5 T) (,func A B C) D (aref W WIDX)
+                      ,const)
+          WIDX (1+ WIDX)
+          A (sha1-rot-30 A))))
+
+(defmacro sha1-FC (n)
+  (let ((func (intern (format "sha1-f%d" n)))
+       (const (intern (format "sha1-const%d" n))))
+    `(setq D (sha1-add (cons 0 0) (sha1-rot-5 E) (,func T A B) C (aref W WIDX)
+                      ,const)
+          WIDX (1+ WIDX)
+          T (sha1-rot-30 T))))
+
+(defmacro sha1-FD (n)
+  (let ((func (intern (format "sha1-f%d" n)))
+       (const (intern (format "sha1-const%d" n))))
+    `(setq C (sha1-add (cons 0 0) (sha1-rot-5 D) (,func E T A) B (aref W WIDX)
+                      ,const)
+          WIDX (1+ WIDX)
+          E (sha1-rot-30 E))))
+
+(defmacro sha1-FE (n)
+  (let ((func (intern (format "sha1-f%d" n)))
+       (const (intern (format "sha1-const%d" n))))
+    `(setq B (sha1-add (cons 0 0) (sha1-rot-5 C) (,func D E T) A (aref W WIDX)
+                      ,const)
+          WIDX (1+ WIDX)
+          D (sha1-rot-30 D))))
+
+(defmacro sha1-FT (n)
+  (let ((func (intern (format "sha1-f%d" n)))
+       (const (intern (format "sha1-const%d" n))))
+    `(setq A (sha1-add (cons 0 0) (sha1-rot-5 B) (,func C D E) T (aref W WIDX)
+                      ,const)
+          WIDX (1+ WIDX)
+          C (sha1-rot-30 C))))
+
+(defun sha1-transform ()
+  "Basic SHA1 step. Transform sha1-digest based on sha1-data."
+  (let ((W (make-vector 80 nil))
+       (WIDX 0)
+       (bidx 0)
+       T A B C D E)
+    (while (< WIDX 16)
+      (aset W WIDX
+           (cons (logior (lsh (aref sha1-data bidx) 8)
+                         (aref sha1-data (setq bidx (1+ bidx))))
+                 (logior (lsh (aref sha1-data (setq bidx (1+ bidx))) 8)
+                         (aref sha1-data (setq bidx (1+ bidx))))))
+      (setq bidx (1+ bidx)
+           WIDX (1+ WIDX)))
+    (while (< WIDX 80)
+      (aset W WIDX (cons 0 0))
+      (sha1-xor (aref W WIDX)
+                  (aref W (- WIDX 3)) (aref W (- WIDX 8))
+                  (aref W (- WIDX 14)) (aref W (- WIDX 16)))
+      (aset W WIDX (sha1-rot-1 (aref W WIDX)))
+      (setq WIDX (1+ WIDX)))
+    (setq A (cons (car (aref sha1-digest 0)) (cdr (aref sha1-digest 0)))
+         B (cons (car (aref sha1-digest 1)) (cdr (aref sha1-digest 1)))
+         C (cons (car (aref sha1-digest 2)) (cdr (aref sha1-digest 2)))
+         D (cons (car (aref sha1-digest 3)) (cdr (aref sha1-digest 3)))
+         E (cons (car (aref sha1-digest 4)) (cdr (aref sha1-digest 4)))
+         WIDX 0)
+
+    (sha1-FA 1) (sha1-FB 1) (sha1-FC 1) (sha1-FD 1) (sha1-FE 1) (sha1-FT 1)
+    (sha1-FA 1) (sha1-FB 1) (sha1-FC 1) (sha1-FD 1) (sha1-FE 1) (sha1-FT 1)
+    (sha1-FA 1) (sha1-FB 1) (sha1-FC 1) (sha1-FD 1) (sha1-FE 1) (sha1-FT 1)
+    (sha1-FA 1) (sha1-FB 1) (sha1-FC 2) (sha1-FD 2) (sha1-FE 2) (sha1-FT 2)
+    (sha1-FA 2) (sha1-FB 2) (sha1-FC 2) (sha1-FD 2) (sha1-FE 2) (sha1-FT 2)
+    (sha1-FA 2) (sha1-FB 2) (sha1-FC 2) (sha1-FD 2) (sha1-FE 2) (sha1-FT 2)
+    (sha1-FA 2) (sha1-FB 2) (sha1-FC 2) (sha1-FD 2) (sha1-FE 3) (sha1-FT 3)
+    (sha1-FA 3) (sha1-FB 3) (sha1-FC 3) (sha1-FD 3) (sha1-FE 3) (sha1-FT 3)
+    (sha1-FA 3) (sha1-FB 3) (sha1-FC 3) (sha1-FD 3) (sha1-FE 3) (sha1-FT 3)
+    (sha1-FA 3) (sha1-FB 3) (sha1-FC 3) (sha1-FD 3) (sha1-FE 3) (sha1-FT 3)
+    (sha1-FA 4) (sha1-FB 4) (sha1-FC 4) (sha1-FD 4) (sha1-FE 4) (sha1-FT 4)
+    (sha1-FA 4) (sha1-FB 4) (sha1-FC 4) (sha1-FD 4) (sha1-FE 4) (sha1-FT 4)
+    (sha1-FA 4) (sha1-FB 4) (sha1-FC 4) (sha1-FD 4) (sha1-FE 4) (sha1-FT 4)
+    (sha1-FA 4) (sha1-FB 4)
+
+    (sha1-add (aref sha1-digest 0) E)
+    (sha1-add (aref sha1-digest 1) T)
+    (sha1-add (aref sha1-digest 2) A)
+    (sha1-add (aref sha1-digest 3) B)
+    (sha1-add (aref sha1-digest 4) C)
+    ))
+
+(defun sha1-final (&optional binary)
+  "Transform buffered sha1-data and return SHA1 message digest.
+If optional argument BINARY is non-nil, then return binary formed 
+string of message digest."
+  (let ((count (logand (lsh (cdr sha1-count-lo) -3) 63)))
+    (when (< (length sha1-data) SHA1-BLOCKSIZE)
+      (setq sha1-data
+           (concat sha1-data
+                   (make-string (- SHA1-BLOCKSIZE (length sha1-data)) 0))))
+    (aset sha1-data count 128)
+    (setq count (1+ count))
+    (if (> count (- SHA1-BLOCKSIZE 8))
+       (progn
+         (setq sha1-data (concat (substring sha1-data 0 count)
+                                 (make-string (- SHA1-BLOCKSIZE count) 0)))
+         (sha1-transform)
+         (setq sha1-data (concat (make-string (- SHA1-BLOCKSIZE 8) 0)
+                                 (substring sha1-data -8))))
+      (setq sha1-data (concat (substring sha1-data 0 count)
+                             (make-string (- SHA1-BLOCKSIZE 8 count) 0)
+                             (substring sha1-data -8))))
+    (aset sha1-data 56 (lsh (car sha1-count-hi) -8))
+    (aset sha1-data 57 (logand 255 (car sha1-count-hi)))
+    (aset sha1-data 58 (lsh (cdr sha1-count-hi) -8))
+    (aset sha1-data 59 (logand 255 (cdr sha1-count-hi)))
+    (aset sha1-data 60 (lsh (car sha1-count-lo) -8))
+    (aset sha1-data 61 (logand 255 (car sha1-count-lo)))
+    (aset sha1-data 62 (lsh (cdr sha1-count-lo) -8))
+    (aset sha1-data 63 (logand 255 (cdr sha1-count-lo)))
+    (sha1-transform)
+    (if binary
+       (mapconcat
+        (lambda (elem)
+          (concat (char-to-string (/ (car elem) 256))
+                  (char-to-string (% (car elem) 256))
+                  (char-to-string (/ (cdr elem) 256))
+                  (char-to-string (% (cdr elem) 256))))
+        (list (aref sha1-digest 0) (aref sha1-digest 1) (aref sha1-digest 2)
+              (aref sha1-digest 3) (aref sha1-digest 4))
+        "")
+      (format "%04x%04x%04x%04x%04x%04x%04x%04x%04x%04x"
+             (car (aref sha1-digest 0)) (cdr (aref sha1-digest 0))
+             (car (aref sha1-digest 1)) (cdr (aref sha1-digest 1))
+             (car (aref sha1-digest 2)) (cdr (aref sha1-digest 2))
+             (car (aref sha1-digest 3)) (cdr (aref sha1-digest 3))
+             (car (aref sha1-digest 4)) (cdr (aref sha1-digest 4)))
+      )))
+
+(defun sha1-encode (message &optional binary)
+  "Encodes MESSAGE using the SHA1 message digest algorithm.
+MESSAGE must be a unibyte-string.
+By default, return a string which formed hex-decimal charcters
+from message digest.
+If optional argument BINARY is non-nil, then return binary formed
+string of message digest."
+  (sha1-init)
+  (sha1-update message)
+  (sha1-final binary))
+
+(defun sha1-encode-binary (message)
+  "Encodes MESSAGE using the SHA1 message digest algorithm.
+MESSAGE must be a unibyte-string.
+Return binary formed string of message digest."
+  (sha1-encode message 'binary))
+
+(provide 'sha1)
+
+;;; sha1.el ends here
index d8e468c..47064b6 100644 (file)
@@ -1,3 +1,21 @@
+2001-02-08 20:00:00  ShengHuo ZHU  <zsh@cs.rochester.edu>
+
+       * message.el (message-cancel-news): Allow to shoot foot.
+       (message-supersede): Ditto.
+
+2001-02-08  Tommi Vainikainen <thv@iki.fi> 
+
+       * gnus-sum.el (gnus-simplify-subject-re): Use
+       message-subject-re-regexp.
+
+2001-02-08 18:00:00  ShengHuo ZHU  <zsh@cs.rochester.edu>
+
+       * nnmail.el (nnmail-expiry-target-group): Bind
+       nnmail-cache-accepted-message-ids to nil.
+
+       * gnus-xmas.el (gnus-xmas-article-display-xface): Use binary
+       coding system.
+
 2001-02-07 23:00:00  ShengHuo ZHU  <zsh@cs.rochester.edu>
 
        * qp.el (quoted-printable-encode-region): Make sure characters are
index e49cb16..5f32936 100644 (file)
@@ -1259,7 +1259,7 @@ end position and text.")
 
 (defsubst gnus-simplify-subject-re (subject)
   "Remove \"Re:\" from subject lines."
-  (if (string-match "^[Rr][Ee]: *" subject)
+  (if (string-match message-subject-re-regexp subject)
       (substring subject (match-end 0))
     subject))
 
index 41bf95c..86622c5 100644 (file)
@@ -801,13 +801,15 @@ XEmacs compatibility workaround."
               (save-excursion
                 (gnus-set-work-buffer)
                 (insert-buffer-substring cur beg end)
-                (gnus-xmas-call-region "uncompface")
-                (goto-char (point-min))
-                (insert "/* Width=48, Height=48 */\n")
-                (gnus-xmas-call-region "icontopbm")
-                (gnus-xmas-call-region "ppmtoxpm")
-                (make-glyph
-                 (vector 'xpm :data (buffer-string))))))
+                (let ((coding-system-for-read 'binary)
+                      (coding-system-for-write 'binary))
+                  (gnus-xmas-call-region "uncompface")
+                  (goto-char (point-min))
+                  (insert "/* Width=48, Height=48 */\n")
+                  (gnus-xmas-call-region "icontopbm")
+                  (gnus-xmas-call-region "ppmtoxpm")
+                  (make-glyph
+                   (vector 'xpm :data (buffer-string)))))))
            (t
             (make-glyph [nothing]))))
          (ext (make-extent (progn
index ba4f568..588ce33 100644 (file)
@@ -902,6 +902,7 @@ candidates:
 `empty-article'     Allow you to post an empty article;
 `quoted-text-only'  Allow you to post quoted text only;
 `multiple-copies'   Allow you to post multiple copies.")
+;; `cancel-messages'   Allow you to cancel or supersede others' messages.
 
 (defsubst message-gnksa-enable-p (feature)
   (or (not (listp message-shoot-gnksa-feet))
@@ -5060,7 +5061,8 @@ If ARG, allow editing of the cancellation message."
                message-id (message-fetch-field "message-id" t)
                distribution (message-fetch-field "distribution")))
        ;; Make sure that this article was written by the user.
-       (unless (or (and sender
+       (unless (or (message-gnksa-enable-p 'cancel-messages)
+                   (and sender
                         (string-equal
                          (downcase sender)
                          (downcase (message-make-sender))))
@@ -5076,7 +5078,7 @@ If ARG, allow editing of the cancellation message."
          (setq buf (set-buffer (get-buffer-create " *message cancel*"))))
        (erase-buffer)
        (insert "Newsgroups: " newsgroups "\n"
-               "From: " from "\n"
+               "From: " from "\n"
                "Subject: cmsg cancel " message-id "\n"
                "Control: cancel " message-id "\n"
                (if distribution
@@ -5109,7 +5111,8 @@ header line with the old Message-ID."
        (sender (message-fetch-field "sender"))
        (from (message-fetch-field "from")))
     ;; Check whether the user owns the article that is to be superseded.
-    (unless (or (and sender
+    (unless (or (message-gnksa-enable-p 'cancel-messages)
+               (and sender
                     (string-equal
                      (downcase sender)
                      (downcase (message-make-sender))))
index cb70183..eeab242 100644 (file)
@@ -1636,10 +1636,13 @@ See the documentation for the variable `nnmail-split-fancy' for documentation."
             (ignore-errors (time-less-p days (time-since time))))))))
 
 (defun nnmail-expiry-target-group (target group)
-  (when (nnheader-functionp target)
-    (setq target (funcall target group)))
-  (unless (eq target 'delete)
-    (gnus-request-accept-article target nil nil t)))
+  (let (nnmail-cache-accepted-message-ids)
+    ;; Don't enter Message-IDs into cache.
+    ;; Let users hack it in TARGET function.
+    (when (nnheader-functionp target)
+      (setq target (funcall target group)))
+    (unless (eq target 'delete)
+      (gnus-request-accept-article target nil nil t))))
 
 (defun nnmail-check-syntax ()
   "Check (and modify) the syntax of the message in the current buffer."