From: yamaoka Date: Fri, 9 Feb 2001 03:35:34 +0000 (+0000) Subject: Synch with Oort Gnus. X-Git-Tag: t-gnus-6_15_0-05-quimby-last-~1 X-Git-Url: http://git.chise.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=a4bc09c2d020b280f8c7d786a6225eeb378d06f4;p=elisp%2Fgnus.git- Synch with Oort Gnus. --- diff --git a/contrib/canlock.el b/contrib/canlock.el new file mode 100644 index 0000000..474b834 --- /dev/null +++ b/contrib/canlock.el @@ -0,0 +1,475 @@ +;;; canlock.el --- Functions for Cancel-Lock feature. +;; Copyright (C) 1998,1999 Katsumi Yamaoka + +;; Author: Katsumi Yamaoka +;; Yuuichi Teranishi +;; Hideyuki SHIRAI +;; Hidekazu Nakamura +;; Ken'ichi Okada +;; Shuhei KOBAYASHI +;; 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 index 0000000..f4706b8 --- /dev/null +++ b/contrib/sha1.el @@ -0,0 +1,397 @@ +;;; sha1.el --- SHA1 Message Digest Algorithm. +;; Copyright (C) 1998,1999 Keiichi Suzuki. + +;; Author: Keiichi Suzuki +;; Author: Katsumi Yamaoka +;; 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 diff --git a/lisp/ChangeLog b/lisp/ChangeLog index d8e468c..47064b6 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,21 @@ +2001-02-08 20:00:00 ShengHuo ZHU + + * message.el (message-cancel-news): Allow to shoot foot. + (message-supersede): Ditto. + +2001-02-08 Tommi Vainikainen + + * gnus-sum.el (gnus-simplify-subject-re): Use + message-subject-re-regexp. + +2001-02-08 18:00:00 ShengHuo ZHU + + * 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 * qp.el (quoted-printable-encode-region): Make sure characters are diff --git a/lisp/gnus-sum.el b/lisp/gnus-sum.el index e49cb16..5f32936 100644 --- a/lisp/gnus-sum.el +++ b/lisp/gnus-sum.el @@ -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)) diff --git a/lisp/gnus-xmas.el b/lisp/gnus-xmas.el index 41bf95c..86622c5 100644 --- a/lisp/gnus-xmas.el +++ b/lisp/gnus-xmas.el @@ -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 diff --git a/lisp/message.el b/lisp/message.el index ba4f568..588ce33 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -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)))) diff --git a/lisp/nnmail.el b/lisp/nnmail.el index cb70183..eeab242 100644 --- a/lisp/nnmail.el +++ b/lisp/nnmail.el @@ -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."