Synch with Oort Gnus.
authoryamaoka <yamaoka>
Wed, 31 Oct 2001 02:42:52 +0000 (02:42 +0000)
committeryamaoka <yamaoka>
Wed, 31 Oct 2001 02:42:52 +0000 (02:42 +0000)
15 files changed:
contrib/ChangeLog
contrib/canlock.el [deleted file]
contrib/hex-util.el [deleted file]
contrib/sha1-el.el [deleted file]
lisp/ChangeLog
lisp/canlock.el [new file with mode: 0644]
lisp/gnus-art.el
lisp/gnus-spec.el
lisp/hex-util.el [new file with mode: 0644]
lisp/lpath.el
lisp/mml2015.el
lisp/sha1-el.el [new file with mode: 0644]
texi/ChangeLog
texi/gnus-ja.texi
texi/gnus.texi

index 1778dde..77c02d2 100644 (file)
@@ -1,3 +1,7 @@
+2001-10-30 21:00:00  ShengHuo ZHU  <zsh@cs.rochester.edu>
+
+       * canlock.el, hex-util.el, sha1-el.el: Move to lisp.
+
 2001-10-30  Katsumi Yamaoka  <yamaoka@jpl.org>
 
        * canlock.el: (canlock-base64-encode-function): Removed.
diff --git a/contrib/canlock.el b/contrib/canlock.el
deleted file mode 100644 (file)
index 89673be..0000000
+++ /dev/null
@@ -1,319 +0,0 @@
-;;; canlock.el --- Functions for Cancel-Lock feature
-;; Copyright (C) 1998, 1999, 2001 Free Software Foundation, Inc.
-
-;; Author: Katsumi Yamaoka <yamaoka@jpl.org>
-;; 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; see the file COPYING.  If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; Commentary:
-
-;; Canlock is a library for generating and verifying Cancel-Lock and/or
-;; Cancel-Key header in news articles.  This is used to protect articles
-;; from rogue cancel, supersede or replace attacks.  The method is based
-;; on draft-ietf-usefor-cancel-lock-01.txt which was released on November
-;; 3rd 1998.  For instance, you can add Cancel-Lock (and possibly Cancel-
-;; Key) header in a news article by using a hook which will be evaluated
-;; just before sending an article as follows:
-;;
-;; (add-hook '*e**a*e-header-hook 'canlock-insert-header t)
-;;
-;; Verifying Cancel-Lock is mainly a function of news servers, however,
-;; you can verify your own article using the command `canlock-verify' in
-;; the (raw) article buffer.  You will be prompted for the password for
-;; each time if the option `canlock-password' or `canlock-password-for-
-;; verify' is nil.  Note that setting these options is a bit unsafe.
-
-;;; Code:
-
-(defconst canlock-version "0.8")
-
-(eval-when-compile
-  (require 'cl))
-
-(autoload 'sha1-binary "sha1-el")
-(autoload 'sha1-encode-binary "sha1")
-(autoload 'base64-encode "base64")
-
-(defgroup canlock nil
-  "The Cancel-Lock feature."
-  :group 'applications)
-
-(defcustom canlock-sha1-function 'sha1-binary
-  "Function to call to make a SHA-1 message digest."
-  :type '(radio (function-item sha1-encode-binary)
-               (function-item sha1-binary)
-               (function-item canlock-sha1-with-openssl)
-               (function :tag "Other"))
-  :group 'canlock)
-
-(defcustom canlock-sha1-function-for-verify canlock-sha1-function
-  "Function to call to make a SHA-1 message digest for verifying."
-  :type '(radio (function-item sha1-encode-binary)
-               (function-item sha1-binary)
-               (function-item canlock-sha1-with-openssl)
-               (function :tag "Other"))
-  :group 'canlock)
-
-(defcustom canlock-openssl-program "openssl"
-  "Name of OpenSSL program."
-  :type 'string
-  :group 'canlock)
-
-(defcustom canlock-openssl-args '("sha1")
-  "Arguments passed to the OpenSSL program."
-  :type 'sexp
-  :group 'canlock)
-
-(defcustom canlock-ignore-errors nil
-  "If non-nil, ignore any error signals."
-  :type 'boolean
-  :group 'canlock)
-
-(defcustom canlock-password nil
-  "Password to use when signing a Cancel-Lock or a Cancel-Key header."
-  :type 'string
-  :group 'canlock)
-
-(defcustom canlock-password-for-verify canlock-password
-  "Password to use when verifying a Cancel-Lock or a Cancel-Key header."
-  :type 'string
-  :group 'canlock)
-
-(defcustom canlock-force-insert-header nil
-  "If non-nil, insert a Cancel-Lock or a Cancel-Key header even if the
-buffer does not look like a news message."
-  :type 'boolean
-  :group 'canlock)
-
-(defun canlock-sha1-with-openssl (message)
-  "Make a SHA-1 digest of MESSAGE using OpenSSL."
-  (with-temp-buffer
-    (let ((coding-system-for-read 'binary)
-         (coding-system-for-write 'binary)
-         selective-display
-         (case-fold-search t))
-      (insert message)
-      (apply 'call-process-region (point-min) (point-max)
-            canlock-openssl-program t t nil canlock-openssl-args)
-      (goto-char (point-min))
-      (while (re-search-forward "[0-9a-f][0-9a-f]" nil t)
-       (replace-match (read (concat "\"\\x" (match-string 0) "\""))))
-      (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 "")))
-    (base64-encode-string (funcall canlock-sha1-function
-                                  (concat
-                                   opad
-                                   (funcall canlock-sha1-function
-                                            (concat ipad message-id)))))))
-
-(defun canlock-narrow-to-header ()
-  "Narrow the buffer to the head of the message."
-  (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 Cancel-Key or Cancel-Lock headers in the narrowed buffer."
-  (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 a list of the values of Cancel-Lock header.
-If KEY is non-nil, look for a Cancel-Key header instead.  The buffer
-is expected to be narrowed to just the headers of the message."
-  (let ((field (mail-fetch-field (if key "Cancel-Key" "Cancel-Lock")))
-       fields rest
-       (case-fold-search t))
-    (when field
-      (setq fields (split-string field "[\t\n\r ,]+"))
-      (while fields
-       (when (string-match "^sha1:" (setq field (pop fields)))
-         (push (substring field 5) rest)))
-      (nreverse rest))))
-
-(defun canlock-fetch-id-for-key ()
-  "Return a Message-ID in Cancel, Supersedes or Replaces header.
-The buffer is expected to be narrowed to just the headers of the
-message."
-  (or (let ((cancel (mail-fetch-field "Control")))
-       (and cancel
-            (string-match "^cancel[\t ]+\\(<[^\t\n @<>]+@[^\t\n @<>]+>\\)"
-                          cancel)
-            (match-string 1 cancel)))
-      (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:"
-                       (base64-encode-string (funcall canlock-sha1-function
-                                                      key-for-lock))
-                       "\n")))))))))
-
-;;;###autoload
-(defun canlock-verify (&optional buffer)
-  "Verify Cancel-Lock or Cancel-Key in BUFFER.
-If BUFFER is nil, the current buffer is assumed.  Signal an error if
-it fails.  You can modify the behavior of this function to return non-
-nil instead of to signal an error by setting the option
-`canlock-ignore-errors' to non-nil."
-  (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 headers")
-         (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
-                 (base64-encode-string (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))))))))
-
-(provide 'canlock)
-
-;;; canlock.el ends here
diff --git a/contrib/hex-util.el b/contrib/hex-util.el
deleted file mode 100644 (file)
index ddf154d..0000000
+++ /dev/null
@@ -1,73 +0,0 @@
-;;; hex-util.el --- Functions to encode/decode hexadecimal string.
-
-;; Copyright (C) 1999, 2001  Free Software Foundation, Inc.
-
-;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
-;; Keywords: data
-
-;; This file is part of FLIM (Faithful Library about Internet Message).
-
-;; 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; see the file COPYING.  If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; Commentary:
-
-;;; Code:
-
-(eval-when-compile
-  (defmacro hex-char-to-num (chr)
-    (` (let ((chr (, chr)))
-        (cond
-         ((and (<= ?a chr)(<= chr ?f)) (+ (- chr ?a) 10))
-         ((and (<= ?A chr)(<= chr ?F)) (+ (- chr ?A) 10))
-         ((and (<= ?0 chr)(<= chr ?9)) (- chr ?0))
-         (t (error "Invalid hexadecimal digit `%c'" chr))))))
-  (defmacro num-to-hex-char (num)
-    (` (aref "0123456789abcdef" (, num)))))
-
-(defun decode-hex-string (string)
-  "Decode hexadecimal STRING to octet string."
-  (let* ((len (length string))
-        (dst (make-string (/ len 2) 0))
-        (idx 0)(pos 0))
-    (while (< pos len)
-;;; logior and lsh are not byte-coded.
-;;;  (aset dst idx (logior (lsh (hex-char-to-num (aref string pos)) 4)
-;;;                        (hex-char-to-num (aref string (1+ pos)))))
-      (aset dst idx (+ (* (hex-char-to-num (aref string pos)) 16)
-                      (hex-char-to-num (aref string (1+ pos)))))
-      (setq idx (1+ idx)
-            pos (+ 2 pos)))
-    dst))
-
-(defun encode-hex-string (string)
-  "Encode octet STRING to hexadecimal string."
-  (let* ((len (length string))
-        (dst (make-string (* len 2) 0))
-        (idx 0)(pos 0))
-    (while (< pos len)
-;;; logand and lsh are not byte-coded.
-;;;  (aset dst idx (num-to-hex-char (logand (lsh (aref string pos) -4) 15)))
-      (aset dst idx (num-to-hex-char (/ (aref string pos) 16)))
-      (setq idx (1+ idx))
-;;;  (aset dst idx (num-to-hex-char (logand (aref string pos) 15)))
-      (aset dst idx (num-to-hex-char (% (aref string pos) 16)))
-      (setq idx (1+ idx)
-            pos (1+ pos)))
-    dst))
-
-(provide 'hex-util)
-
-;;; hex-util.el ends here
diff --git a/contrib/sha1-el.el b/contrib/sha1-el.el
deleted file mode 100644 (file)
index 15c1f5a..0000000
+++ /dev/null
@@ -1,423 +0,0 @@
-;;; sha1-el.el --- SHA1 Secure Hash Algorithm in Emacs-Lisp.
-
-;; Copyright (C) 1999, 2001  Free Software Foundation, Inc.
-
-;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
-;; Keywords: SHA1, FIPS 180-1
-
-;; This file is part of FLIM (Faithful Library about Internet Message).
-
-;; 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; 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 program is implemented from the definition of SHA-1 in FIPS PUB
-;; 180-1 (Federal Information Processing Standards Publication 180-1),
-;; "Announcing the Standard for SECURE HASH STANDARD".
-;; <URL:http://www.itl.nist.gov/div897/pubs/fip180-1.htm>
-;; (EXCEPTION; two optimizations taken from GnuPG/cipher/sha1.c)
-;;
-;; Test cases from FIPS PUB 180-1.
-;;
-;; (sha1 "abc")
-;; => a9993e364706816aba3e25717850c26c9cd0d89d
-;;
-;; (sha1 "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq")
-;; => 84983e441c3bd26ebaae4aa1f95129e5e54670f1
-;;
-;; (sha1 (make-string 1000000 ?a))
-;; => 34aa973cd4c4daa4f61eeb2bdbad27316534016f
-;;
-;; BUGS:
-;;  * It is assumed that length of input string is less than 2^29 bytes.
-;;  * It is caller's responsibility to make string (or region) unibyte.
-;;
-;; TODO:
-;;  * Rewrite from scratch!
-;;    This version is much faster than Keiichi Suzuki's another sha1.el,
-;;    but it is too dirty.
-
-;;; Code:
-
-(require 'hex-util)
-
-;;;
-;;; external SHA1 function.
-;;;
-
-(defvar sha1-maximum-internal-length 500
-  "*Maximum length of message to use lisp version of SHA1 function.
-If message is longer than this, `sha1-program' is used instead.
-
-If this variable is set to 0, use extarnal program only.
-If this variable is set to nil, use internal function only.")
-
-(defvar sha1-program '("openssl" "sha1")
-  "*Name of program to compute SHA1.
-It must be a string \(program name\) or list of strings \(name and its args\).")
-
-(defun sha1-string-external (string)
-  ;; `with-temp-buffer' is new in v20, so we do not use it.
-  (save-excursion
-    (let (buffer)
-      (unwind-protect
-         (let (prog args)
-           (if (consp sha1-program)
-               (setq prog (car sha1-program)
-                     args (cdr sha1-program))
-             (setq prog sha1-program
-                   args nil))
-           (setq buffer (set-buffer
-                         (generate-new-buffer " *sha1 external*")))
-           (insert string)
-           (apply (function call-process-region)
-                  (point-min)(point-max)
-                  prog t t nil args)
-           ;; SHA1 is 40 bytes long in hexadecimal form.
-           (buffer-substring (point-min)(+ (point-min) 40)))
-       (and buffer
-            (buffer-name buffer)
-            (kill-buffer buffer))))))
-
-(defun sha1-region-external (beg end)
-  (sha1-string-external (buffer-substring-no-properties beg end)))
-
-;;;
-;;; internal SHA1 function.
-;;;
-
-(eval-when-compile
-  ;; optional second arg of string-to-number is new in v20.
-  (defconst sha1-K0-high 23170)                ; (string-to-number "5A82" 16)
-  (defconst sha1-K0-low  31129)                ; (string-to-number "7999" 16)
-  (defconst sha1-K1-high 28377)                ; (string-to-number "6ED9" 16)
-  (defconst sha1-K1-low  60321)                ; (string-to-number "EBA1" 16)
-  (defconst sha1-K2-high 36635)                ; (string-to-number "8F1B" 16)
-  (defconst sha1-K2-low  48348)                ; (string-to-number "BCDC" 16)
-  (defconst sha1-K3-high 51810)                ; (string-to-number "CA62" 16)
-  (defconst sha1-K3-low  49622)                ; (string-to-number "C1D6" 16)
-
-;;; original definition of sha1-F0.
-;;; (defmacro sha1-F0 (B C D)
-;;;   (` (logior (logand (, B) (, C))
-;;;         (logand (lognot (, B)) (, D)))))
-;;; a little optimization from GnuPG/cipher/sha1.c.
-  (defmacro sha1-F0 (B C D)
-    (` (logxor (, D) (logand (, B) (logxor (, C) (, D))))))
-  (defmacro sha1-F1 (B C D)
-    (` (logxor (, B) (, C) (, D))))
-;;; original definition of sha1-F2.
-;;; (defmacro sha1-F2 (B C D)
-;;;   (` (logior (logand (, B) (, C))
-;;;         (logand (, B) (, D))
-;;;         (logand (, C) (, D)))))
-;;; a little optimization from GnuPG/cipher/sha1.c.
-  (defmacro sha1-F2 (B C D)
-    (` (logior (logand (, B) (, C))
-              (logand (, D) (logior (, B) (, C))))))
-  (defmacro sha1-F3 (B C D)
-    (` (logxor (, B) (, C) (, D))))
-
-  (defmacro sha1-S1  (W-high W-low)
-    (` (let ((W-high (, W-high))
-            (W-low  (, W-low)))
-        (setq S1W-high (+ (% (* W-high 2) 65536)
-                          (/ W-low (, (/ 65536 2)))))
-        (setq S1W-low (+ (/ W-high (, (/ 65536 2)))
-                         (% (* W-low 2) 65536))))))
-  (defmacro sha1-S5  (A-high A-low)
-    (` (progn
-        (setq S5A-high (+ (% (* (, A-high) 32) 65536)
-                          (/ (, A-low) (, (/ 65536 32)))))
-        (setq S5A-low  (+ (/ (, A-high) (, (/ 65536 32)))
-                          (% (* (, A-low) 32) 65536))))))
-  (defmacro sha1-S30 (B-high B-low)
-    (` (progn
-        (setq S30B-high (+ (/ (, B-high) 4)
-                           (* (% (, B-low) 4) (, (/ 65536 4)))))
-        (setq S30B-low  (+ (/ (, B-low) 4)
-                           (* (% (, B-high) 4) (, (/ 65536 4))))))))
-
-  (defmacro sha1-OP (round)
-    (` (progn
-        (sha1-S5 sha1-A-high sha1-A-low)
-        (sha1-S30 sha1-B-high sha1-B-low)
-        (setq sha1-A-low (+ ((, (intern (format "sha1-F%d" round)))
-                             sha1-B-low sha1-C-low sha1-D-low)
-                            sha1-E-low
-                            (, (symbol-value
-                                (intern (format "sha1-K%d-low" round))))
-                            (aref block-low idx)
-                            (progn
-                              (setq sha1-E-low sha1-D-low)
-                              (setq sha1-D-low sha1-C-low)
-                              (setq sha1-C-low S30B-low)
-                              (setq sha1-B-low sha1-A-low)
-                              S5A-low)))
-        (setq carry (/ sha1-A-low 65536))
-        (setq sha1-A-low (% sha1-A-low 65536))
-        (setq sha1-A-high (% (+ ((, (intern (format "sha1-F%d" round)))
-                                 sha1-B-high sha1-C-high sha1-D-high)
-                                sha1-E-high
-                                (, (symbol-value
-                                    (intern (format "sha1-K%d-high" round))))
-                                (aref block-high idx)
-                                (progn
-                                  (setq sha1-E-high sha1-D-high)
-                                  (setq sha1-D-high sha1-C-high)
-                                  (setq sha1-C-high S30B-high)
-                                  (setq sha1-B-high sha1-A-high)
-                                  S5A-high)
-                                carry)
-                             65536)))))
-
-  (defmacro sha1-add-to-H (H X)
-    (` (progn
-        (setq (, (intern (format "sha1-%s-low" H)))
-              (+ (, (intern (format "sha1-%s-low" H)))
-                 (, (intern (format "sha1-%s-low" X)))))
-        (setq carry (/ (, (intern (format "sha1-%s-low" H))) 65536))
-        (setq (, (intern (format "sha1-%s-low" H)))
-              (% (, (intern (format "sha1-%s-low" H))) 65536))
-        (setq (, (intern (format "sha1-%s-high" H)))
-              (% (+ (, (intern (format "sha1-%s-high" H)))
-                    (, (intern (format "sha1-%s-high" X)))
-                    carry)
-                 65536)))))
-  )
-
-;;; buffers (H0 H1 H2 H3 H4).
-(defvar sha1-H0-high)
-(defvar sha1-H0-low)
-(defvar sha1-H1-high)
-(defvar sha1-H1-low)
-(defvar sha1-H2-high)
-(defvar sha1-H2-low)
-(defvar sha1-H3-high)
-(defvar sha1-H3-low)
-(defvar sha1-H4-high)
-(defvar sha1-H4-low)
-
-(defun sha1-block (block-high block-low)
-  (let (;; step (c) --- initialize buffers (A B C D E).
-       (sha1-A-high sha1-H0-high) (sha1-A-low sha1-H0-low)
-       (sha1-B-high sha1-H1-high) (sha1-B-low sha1-H1-low)
-       (sha1-C-high sha1-H2-high) (sha1-C-low sha1-H2-low)
-       (sha1-D-high sha1-H3-high) (sha1-D-low sha1-H3-low)
-       (sha1-E-high sha1-H4-high) (sha1-E-low sha1-H4-low)
-       (idx 16))
-    ;; step (b).
-    (let (;; temporary variables used in sha1-S1 macro.
-         S1W-high S1W-low)
-      (while (< idx 80)
-       (sha1-S1 (logxor (aref block-high (- idx 3))
-                        (aref block-high (- idx 8))
-                        (aref block-high (- idx 14))
-                        (aref block-high (- idx 16)))
-                (logxor (aref block-low  (- idx 3))
-                        (aref block-low  (- idx 8))
-                        (aref block-low  (- idx 14))
-                        (aref block-low  (- idx 16))))
-       (aset block-high idx S1W-high)
-       (aset block-low  idx S1W-low)
-       (setq idx (1+ idx))))
-    ;; step (d).
-    (setq idx 0)
-    (let (;; temporary variables used in sha1-OP macro.
-         S5A-high S5A-low S30B-high S30B-low carry)
-      (while (< idx 20) (sha1-OP 0) (setq idx (1+ idx)))
-      (while (< idx 40) (sha1-OP 1) (setq idx (1+ idx)))
-      (while (< idx 60) (sha1-OP 2) (setq idx (1+ idx)))
-      (while (< idx 80) (sha1-OP 3) (setq idx (1+ idx))))
-    ;; step (e).
-    (let (;; temporary variables used in sha1-add-to-H macro.
-         carry)
-      (sha1-add-to-H H0 A)
-      (sha1-add-to-H H1 B)
-      (sha1-add-to-H H2 C)
-      (sha1-add-to-H H3 D)
-      (sha1-add-to-H H4 E))))
-
-(defun sha1-binary (string)
-  "Return the SHA1 of STRING in binary form."
-  (let (;; prepare buffers for a block. byte-length of block is 64.
-       ;; input block is split into two vectors.
-       ;;
-       ;; input block: 00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F ...
-       ;; block-high:  +-0-+       +-1-+       +-2-+       +-3-+
-       ;; block-low:         +-0-+       +-1-+       +-2-+       +-3-+
-       ;;
-       ;; length of each vector is 80, and elements of each vector are
-       ;; 16bit integers.  elements 0x10-0x4F of each vector are
-       ;; assigned later in `sha1-block'.
-       (block-high (eval-when-compile (make-vector 80 nil)))
-       (block-low  (eval-when-compile (make-vector 80 nil))))
-    (unwind-protect
-       (let* (;; byte-length of input string.
-              (len (length string))
-              (lim (* (/ len 64) 64))
-              (rem (% len 4))
-              (idx 0)(pos 0))
-         ;; initialize buffers (H0 H1 H2 H3 H4).
-         (setq sha1-H0-high 26437      ; (string-to-number "6745" 16)
-               sha1-H0-low  8961       ; (string-to-number "2301" 16)
-               sha1-H1-high 61389      ; (string-to-number "EFCD" 16)
-               sha1-H1-low  43913      ; (string-to-number "AB89" 16)
-               sha1-H2-high 39098      ; (string-to-number "98BA" 16)
-               sha1-H2-low  56574      ; (string-to-number "DCFE" 16)
-               sha1-H3-high 4146       ; (string-to-number "1032" 16)
-               sha1-H3-low  21622      ; (string-to-number "5476" 16)
-               sha1-H4-high 50130      ; (string-to-number "C3D2" 16)
-               sha1-H4-low  57840)     ; (string-to-number "E1F0" 16)
-         ;; loop for each 64 bytes block.
-         (while (< pos lim)
-           ;; step (a).
-           (setq idx 0)
-           (while (< idx 16)
-             (aset block-high idx (+ (* (aref string pos) 256)
-                                     (aref string (1+ pos))))
-             (setq pos (+ pos 2))
-             (aset block-low  idx (+ (* (aref string pos) 256)
-                                     (aref string (1+ pos))))
-             (setq pos (+ pos 2))
-             (setq idx (1+ idx)))
-           (sha1-block block-high block-low))
-         ;; last block.
-         (if (prog1
-                 (< (- len lim) 56)
-               (setq lim (- len rem))
-               (setq idx 0)
-               (while (< pos lim)
-                 (aset block-high idx (+ (* (aref string pos) 256)
-                                         (aref string (1+ pos))))
-                 (setq pos (+ pos 2))
-                 (aset block-low  idx (+ (* (aref string pos) 256)
-                                         (aref string (1+ pos))))
-                 (setq pos (+ pos 2))
-                 (setq idx (1+ idx)))
-               ;; this is the last (at most) 32bit word.
-               (cond
-                ((= rem 3)
-                 (aset block-high idx (+ (* (aref string pos) 256)
-                                         (aref string (1+ pos))))
-                 (setq pos (+ pos 2))
-                 (aset block-low  idx (+ (* (aref string pos) 256)
-                                         128)))
-                ((= rem 2)
-                 (aset block-high idx (+ (* (aref string pos) 256)
-                                         (aref string (1+ pos))))
-                 (aset block-low  idx 32768))
-                ((= rem 1)
-                 (aset block-high idx (+ (* (aref string pos) 256)
-                                         128))
-                 (aset block-low  idx 0))
-                (t ;; (= rem 0)
-                 (aset block-high idx 32768)
-                 (aset block-low  idx 0)))
-               (setq idx (1+ idx))
-               (while (< idx 16)
-                 (aset block-high idx 0)
-                 (aset block-low  idx 0)
-                 (setq idx (1+ idx))))
-             ;; last block has enough room to write the length of string.
-             (progn
-               ;; write bit length of string to last 4 bytes of the block.
-               (aset block-low  15 (* (% len 8192) 8))
-               (setq len (/ len 8192))
-               (aset block-high 15 (% len 65536))
-               ;; XXX: It is not practical to compute SHA1 of
-               ;;      such a huge message on emacs.
-               ;; (setq len (/ len 65536))     ; for 64bit emacs.
-               ;; (aset block-low  14 (% len 65536))
-               ;; (aset block-high 14 (/ len 65536))
-               (sha1-block block-high block-low))
-           ;; need one more block.
-           (sha1-block block-high block-low)
-           (fillarray block-high 0)
-           (fillarray block-low  0)
-           ;; write bit length of string to last 4 bytes of the block.
-           (aset block-low  15 (* (% len 8192) 8))
-           (setq len (/ len 8192))
-           (aset block-high 15 (% len 65536))
-           ;; XXX: It is not practical to compute SHA1 of
-           ;;      such a huge message on emacs.
-           ;; (setq len (/ len 65536))         ; for 64bit emacs.
-           ;; (aset block-low  14 (% len 65536))
-           ;; (aset block-high 14 (/ len 65536))
-           (sha1-block block-high block-low))
-         ;; make output string (in binary form).
-         (let ((result (make-string 20 0)))
-           (aset result  0 (/ sha1-H0-high 256))
-           (aset result  1 (% sha1-H0-high 256))
-           (aset result  2 (/ sha1-H0-low  256))
-           (aset result  3 (% sha1-H0-low  256))
-           (aset result  4 (/ sha1-H1-high 256))
-           (aset result  5 (% sha1-H1-high 256))
-           (aset result  6 (/ sha1-H1-low  256))
-           (aset result  7 (% sha1-H1-low  256))
-           (aset result  8 (/ sha1-H2-high 256))
-           (aset result  9 (% sha1-H2-high 256))
-           (aset result 10 (/ sha1-H2-low  256))
-           (aset result 11 (% sha1-H2-low  256))
-           (aset result 12 (/ sha1-H3-high 256))
-           (aset result 13 (% sha1-H3-high 256))
-           (aset result 14 (/ sha1-H3-low  256))
-           (aset result 15 (% sha1-H3-low  256))
-           (aset result 16 (/ sha1-H4-high 256))
-           (aset result 17 (% sha1-H4-high 256))
-           (aset result 18 (/ sha1-H4-low  256))
-           (aset result 19 (% sha1-H4-low  256))
-           result))
-      ;; do not leave a copy of input string.
-      (fillarray block-high nil)
-      (fillarray block-low  nil))))
-
-(defun sha1-string-internal (string)
-  (encode-hex-string (sha1-binary string)))
-
-(defun sha1-region-internal (beg end)
-  (sha1-string-internal (buffer-substring-no-properties beg end)))
-
-;;;
-;;; application interface.
-;;;
-
-(defun sha1-region (beg end)
-  (if (and sha1-maximum-internal-length
-          (> (abs (- end beg)) sha1-maximum-internal-length))
-      (sha1-region-external beg end)
-    (sha1-region-internal beg end)))
-
-(defun sha1-string (string)
-  (if (and sha1-maximum-internal-length
-          (> (length string) sha1-maximum-internal-length))
-      (sha1-string-external string)
-    (sha1-string-internal string)))
-
-(defun sha1 (object &optional beg end)
-  "Return the SHA1 (Secure Hash Algorithm) of an object.
-OBJECT is either a string or a buffer.
-Optional arguments BEG and END denote buffer positions for computing the
-hash of a portion of OBJECT."
-  (if (stringp object)
-      (sha1-string object)
-    (save-excursion
-      (set-buffer object)
-      (sha1-region (or beg (point-min)) (or end (point-max))))))
-
-(provide 'sha1-el)
-
-;;; sha1-el.el ends here
index 5b84e9d..7606275 100644 (file)
@@ -1,3 +1,21 @@
+2001-10-30 21:00:00  ShengHuo ZHU  <zsh@cs.rochester.edu>
+
+       * canlock.el, sha1-el.el, hex-util.el: Move from contrib
+       directory. Thanks to Katsumi Yamaoka <yamaoka@jpl.org> and Shuhei
+       KOBAYASHI <shuhei@aqua.ocn.ne.jp>.
+       
+2001-10-30 20:00:00  ShengHuo ZHU  <zsh@cs.rochester.edu>
+
+       * gnus-art.el (article-display-x-face): Nix buffer-read-only
+       again.
+
+       * mml2015.el (mml2015-gpg-verify): Convert <LF> to <CR><LF>.
+
+2001-10-30 13:00:00  ShengHuo ZHU  <zsh@cs.rochester.edu>
+
+       * gnus-spec.el (gnus-parse-simple-format): Use
+         buffer-substring-no-properties.
+
 2001-10-30  Katsumi Yamaoka  <yamaoka@jpl.org>
 
        * gnus-art.el (article-verify-cancel-lock): New function.
diff --git a/lisp/canlock.el b/lisp/canlock.el
new file mode 100644 (file)
index 0000000..89673be
--- /dev/null
@@ -0,0 +1,319 @@
+;;; canlock.el --- Functions for Cancel-Lock feature
+;; Copyright (C) 1998, 1999, 2001 Free Software Foundation, Inc.
+
+;; Author: Katsumi Yamaoka <yamaoka@jpl.org>
+;; 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; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; Canlock is a library for generating and verifying Cancel-Lock and/or
+;; Cancel-Key header in news articles.  This is used to protect articles
+;; from rogue cancel, supersede or replace attacks.  The method is based
+;; on draft-ietf-usefor-cancel-lock-01.txt which was released on November
+;; 3rd 1998.  For instance, you can add Cancel-Lock (and possibly Cancel-
+;; Key) header in a news article by using a hook which will be evaluated
+;; just before sending an article as follows:
+;;
+;; (add-hook '*e**a*e-header-hook 'canlock-insert-header t)
+;;
+;; Verifying Cancel-Lock is mainly a function of news servers, however,
+;; you can verify your own article using the command `canlock-verify' in
+;; the (raw) article buffer.  You will be prompted for the password for
+;; each time if the option `canlock-password' or `canlock-password-for-
+;; verify' is nil.  Note that setting these options is a bit unsafe.
+
+;;; Code:
+
+(defconst canlock-version "0.8")
+
+(eval-when-compile
+  (require 'cl))
+
+(autoload 'sha1-binary "sha1-el")
+(autoload 'sha1-encode-binary "sha1")
+(autoload 'base64-encode "base64")
+
+(defgroup canlock nil
+  "The Cancel-Lock feature."
+  :group 'applications)
+
+(defcustom canlock-sha1-function 'sha1-binary
+  "Function to call to make a SHA-1 message digest."
+  :type '(radio (function-item sha1-encode-binary)
+               (function-item sha1-binary)
+               (function-item canlock-sha1-with-openssl)
+               (function :tag "Other"))
+  :group 'canlock)
+
+(defcustom canlock-sha1-function-for-verify canlock-sha1-function
+  "Function to call to make a SHA-1 message digest for verifying."
+  :type '(radio (function-item sha1-encode-binary)
+               (function-item sha1-binary)
+               (function-item canlock-sha1-with-openssl)
+               (function :tag "Other"))
+  :group 'canlock)
+
+(defcustom canlock-openssl-program "openssl"
+  "Name of OpenSSL program."
+  :type 'string
+  :group 'canlock)
+
+(defcustom canlock-openssl-args '("sha1")
+  "Arguments passed to the OpenSSL program."
+  :type 'sexp
+  :group 'canlock)
+
+(defcustom canlock-ignore-errors nil
+  "If non-nil, ignore any error signals."
+  :type 'boolean
+  :group 'canlock)
+
+(defcustom canlock-password nil
+  "Password to use when signing a Cancel-Lock or a Cancel-Key header."
+  :type 'string
+  :group 'canlock)
+
+(defcustom canlock-password-for-verify canlock-password
+  "Password to use when verifying a Cancel-Lock or a Cancel-Key header."
+  :type 'string
+  :group 'canlock)
+
+(defcustom canlock-force-insert-header nil
+  "If non-nil, insert a Cancel-Lock or a Cancel-Key header even if the
+buffer does not look like a news message."
+  :type 'boolean
+  :group 'canlock)
+
+(defun canlock-sha1-with-openssl (message)
+  "Make a SHA-1 digest of MESSAGE using OpenSSL."
+  (with-temp-buffer
+    (let ((coding-system-for-read 'binary)
+         (coding-system-for-write 'binary)
+         selective-display
+         (case-fold-search t))
+      (insert message)
+      (apply 'call-process-region (point-min) (point-max)
+            canlock-openssl-program t t nil canlock-openssl-args)
+      (goto-char (point-min))
+      (while (re-search-forward "[0-9a-f][0-9a-f]" nil t)
+       (replace-match (read (concat "\"\\x" (match-string 0) "\""))))
+      (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 "")))
+    (base64-encode-string (funcall canlock-sha1-function
+                                  (concat
+                                   opad
+                                   (funcall canlock-sha1-function
+                                            (concat ipad message-id)))))))
+
+(defun canlock-narrow-to-header ()
+  "Narrow the buffer to the head of the message."
+  (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 Cancel-Key or Cancel-Lock headers in the narrowed buffer."
+  (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 a list of the values of Cancel-Lock header.
+If KEY is non-nil, look for a Cancel-Key header instead.  The buffer
+is expected to be narrowed to just the headers of the message."
+  (let ((field (mail-fetch-field (if key "Cancel-Key" "Cancel-Lock")))
+       fields rest
+       (case-fold-search t))
+    (when field
+      (setq fields (split-string field "[\t\n\r ,]+"))
+      (while fields
+       (when (string-match "^sha1:" (setq field (pop fields)))
+         (push (substring field 5) rest)))
+      (nreverse rest))))
+
+(defun canlock-fetch-id-for-key ()
+  "Return a Message-ID in Cancel, Supersedes or Replaces header.
+The buffer is expected to be narrowed to just the headers of the
+message."
+  (or (let ((cancel (mail-fetch-field "Control")))
+       (and cancel
+            (string-match "^cancel[\t ]+\\(<[^\t\n @<>]+@[^\t\n @<>]+>\\)"
+                          cancel)
+            (match-string 1 cancel)))
+      (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:"
+                       (base64-encode-string (funcall canlock-sha1-function
+                                                      key-for-lock))
+                       "\n")))))))))
+
+;;;###autoload
+(defun canlock-verify (&optional buffer)
+  "Verify Cancel-Lock or Cancel-Key in BUFFER.
+If BUFFER is nil, the current buffer is assumed.  Signal an error if
+it fails.  You can modify the behavior of this function to return non-
+nil instead of to signal an error by setting the option
+`canlock-ignore-errors' to non-nil."
+  (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 headers")
+         (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
+                 (base64-encode-string (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))))))))
+
+(provide 'canlock)
+
+;;; canlock.el ends here
index 5841211..d77a5db 100644 (file)
@@ -1827,7 +1827,8 @@ MAP is an alist where the elements are on the form (\"from\" \"to\")."
          ;; We now have the area of the buffer where the X-Face is stored.
          (save-excursion
            (let ((beg (point))
-                 (end (1- (re-search-forward "^\\($\\|[^ \t]\\)" nil t))))
+                 (end (1- (re-search-forward "^\\($\\|[^ \t]\\)" nil t)))
+                 buffer-read-only)
              ;; We display the face.
              (if (symbolp gnus-article-x-face-command)
                  ;; The command is a lisp function, so we call it.
index bbab0bc..d0d50e2 100644 (file)
@@ -602,7 +602,7 @@ characters when given a pad value."
                  (push el flist)))
            (insert elem-type)
            (push (car elem) flist))))
-      (setq fstring (buffer-string)))
+      (setq fstring (buffer-substring-no-properties (point-min) (point-max))))
 
     ;; Do some postprocessing to increase efficiency.
     (setq
diff --git a/lisp/hex-util.el b/lisp/hex-util.el
new file mode 100644 (file)
index 0000000..ddf154d
--- /dev/null
@@ -0,0 +1,73 @@
+;;; hex-util.el --- Functions to encode/decode hexadecimal string.
+
+;; Copyright (C) 1999, 2001  Free Software Foundation, Inc.
+
+;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
+;; Keywords: data
+
+;; This file is part of FLIM (Faithful Library about Internet Message).
+
+;; 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; see the file COPYING.  If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(eval-when-compile
+  (defmacro hex-char-to-num (chr)
+    (` (let ((chr (, chr)))
+        (cond
+         ((and (<= ?a chr)(<= chr ?f)) (+ (- chr ?a) 10))
+         ((and (<= ?A chr)(<= chr ?F)) (+ (- chr ?A) 10))
+         ((and (<= ?0 chr)(<= chr ?9)) (- chr ?0))
+         (t (error "Invalid hexadecimal digit `%c'" chr))))))
+  (defmacro num-to-hex-char (num)
+    (` (aref "0123456789abcdef" (, num)))))
+
+(defun decode-hex-string (string)
+  "Decode hexadecimal STRING to octet string."
+  (let* ((len (length string))
+        (dst (make-string (/ len 2) 0))
+        (idx 0)(pos 0))
+    (while (< pos len)
+;;; logior and lsh are not byte-coded.
+;;;  (aset dst idx (logior (lsh (hex-char-to-num (aref string pos)) 4)
+;;;                        (hex-char-to-num (aref string (1+ pos)))))
+      (aset dst idx (+ (* (hex-char-to-num (aref string pos)) 16)
+                      (hex-char-to-num (aref string (1+ pos)))))
+      (setq idx (1+ idx)
+            pos (+ 2 pos)))
+    dst))
+
+(defun encode-hex-string (string)
+  "Encode octet STRING to hexadecimal string."
+  (let* ((len (length string))
+        (dst (make-string (* len 2) 0))
+        (idx 0)(pos 0))
+    (while (< pos len)
+;;; logand and lsh are not byte-coded.
+;;;  (aset dst idx (num-to-hex-char (logand (lsh (aref string pos) -4) 15)))
+      (aset dst idx (num-to-hex-char (/ (aref string pos) 16)))
+      (setq idx (1+ idx))
+;;;  (aset dst idx (num-to-hex-char (logand (aref string pos) 15)))
+      (aset dst idx (num-to-hex-char (% (aref string pos) 16)))
+      (setq idx (1+ idx)
+            pos (1+ pos)))
+    dst))
+
+(provide 'hex-util)
+
+;;; hex-util.el ends here
index 2b87d7f..ef92465 100644 (file)
@@ -22,7 +22,6 @@
               mail-aliases-setup mm-copy-tree
               mule-write-region-no-coding-system put-image
               ring-elements
-              canlock-verify
               charsetp
               coding-system-p
               propertize make-mode-line-mouse2-map
index a59ff3f..f547cd1 100644 (file)
@@ -445,6 +445,16 @@ by you.")
       (with-temp-buffer
        (setq message (current-buffer))
        (insert part)
+       ;; Convert <LF> to <CR><LF> in verify mode.  Sign and
+       ;; clearsign use --textmode. The conversion is not necessary.
+       ;; In clearverify, the conversion is not necessary either.
+       (goto-char (point-min))
+       (end-of-line)
+       (while (not (eobp))
+         (unless (eq (char-before) ?\r)
+           (insert "\r"))
+         (forward-line)
+         (end-of-line))
        (with-temp-buffer
          (setq signature (current-buffer))
          (unless (setq part (mm-find-part-by-type
diff --git a/lisp/sha1-el.el b/lisp/sha1-el.el
new file mode 100644 (file)
index 0000000..15c1f5a
--- /dev/null
@@ -0,0 +1,423 @@
+;;; sha1-el.el --- SHA1 Secure Hash Algorithm in Emacs-Lisp.
+
+;; Copyright (C) 1999, 2001  Free Software Foundation, Inc.
+
+;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
+;; Keywords: SHA1, FIPS 180-1
+
+;; This file is part of FLIM (Faithful Library about Internet Message).
+
+;; 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; 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 program is implemented from the definition of SHA-1 in FIPS PUB
+;; 180-1 (Federal Information Processing Standards Publication 180-1),
+;; "Announcing the Standard for SECURE HASH STANDARD".
+;; <URL:http://www.itl.nist.gov/div897/pubs/fip180-1.htm>
+;; (EXCEPTION; two optimizations taken from GnuPG/cipher/sha1.c)
+;;
+;; Test cases from FIPS PUB 180-1.
+;;
+;; (sha1 "abc")
+;; => a9993e364706816aba3e25717850c26c9cd0d89d
+;;
+;; (sha1 "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq")
+;; => 84983e441c3bd26ebaae4aa1f95129e5e54670f1
+;;
+;; (sha1 (make-string 1000000 ?a))
+;; => 34aa973cd4c4daa4f61eeb2bdbad27316534016f
+;;
+;; BUGS:
+;;  * It is assumed that length of input string is less than 2^29 bytes.
+;;  * It is caller's responsibility to make string (or region) unibyte.
+;;
+;; TODO:
+;;  * Rewrite from scratch!
+;;    This version is much faster than Keiichi Suzuki's another sha1.el,
+;;    but it is too dirty.
+
+;;; Code:
+
+(require 'hex-util)
+
+;;;
+;;; external SHA1 function.
+;;;
+
+(defvar sha1-maximum-internal-length 500
+  "*Maximum length of message to use lisp version of SHA1 function.
+If message is longer than this, `sha1-program' is used instead.
+
+If this variable is set to 0, use extarnal program only.
+If this variable is set to nil, use internal function only.")
+
+(defvar sha1-program '("openssl" "sha1")
+  "*Name of program to compute SHA1.
+It must be a string \(program name\) or list of strings \(name and its args\).")
+
+(defun sha1-string-external (string)
+  ;; `with-temp-buffer' is new in v20, so we do not use it.
+  (save-excursion
+    (let (buffer)
+      (unwind-protect
+         (let (prog args)
+           (if (consp sha1-program)
+               (setq prog (car sha1-program)
+                     args (cdr sha1-program))
+             (setq prog sha1-program
+                   args nil))
+           (setq buffer (set-buffer
+                         (generate-new-buffer " *sha1 external*")))
+           (insert string)
+           (apply (function call-process-region)
+                  (point-min)(point-max)
+                  prog t t nil args)
+           ;; SHA1 is 40 bytes long in hexadecimal form.
+           (buffer-substring (point-min)(+ (point-min) 40)))
+       (and buffer
+            (buffer-name buffer)
+            (kill-buffer buffer))))))
+
+(defun sha1-region-external (beg end)
+  (sha1-string-external (buffer-substring-no-properties beg end)))
+
+;;;
+;;; internal SHA1 function.
+;;;
+
+(eval-when-compile
+  ;; optional second arg of string-to-number is new in v20.
+  (defconst sha1-K0-high 23170)                ; (string-to-number "5A82" 16)
+  (defconst sha1-K0-low  31129)                ; (string-to-number "7999" 16)
+  (defconst sha1-K1-high 28377)                ; (string-to-number "6ED9" 16)
+  (defconst sha1-K1-low  60321)                ; (string-to-number "EBA1" 16)
+  (defconst sha1-K2-high 36635)                ; (string-to-number "8F1B" 16)
+  (defconst sha1-K2-low  48348)                ; (string-to-number "BCDC" 16)
+  (defconst sha1-K3-high 51810)                ; (string-to-number "CA62" 16)
+  (defconst sha1-K3-low  49622)                ; (string-to-number "C1D6" 16)
+
+;;; original definition of sha1-F0.
+;;; (defmacro sha1-F0 (B C D)
+;;;   (` (logior (logand (, B) (, C))
+;;;         (logand (lognot (, B)) (, D)))))
+;;; a little optimization from GnuPG/cipher/sha1.c.
+  (defmacro sha1-F0 (B C D)
+    (` (logxor (, D) (logand (, B) (logxor (, C) (, D))))))
+  (defmacro sha1-F1 (B C D)
+    (` (logxor (, B) (, C) (, D))))
+;;; original definition of sha1-F2.
+;;; (defmacro sha1-F2 (B C D)
+;;;   (` (logior (logand (, B) (, C))
+;;;         (logand (, B) (, D))
+;;;         (logand (, C) (, D)))))
+;;; a little optimization from GnuPG/cipher/sha1.c.
+  (defmacro sha1-F2 (B C D)
+    (` (logior (logand (, B) (, C))
+              (logand (, D) (logior (, B) (, C))))))
+  (defmacro sha1-F3 (B C D)
+    (` (logxor (, B) (, C) (, D))))
+
+  (defmacro sha1-S1  (W-high W-low)
+    (` (let ((W-high (, W-high))
+            (W-low  (, W-low)))
+        (setq S1W-high (+ (% (* W-high 2) 65536)
+                          (/ W-low (, (/ 65536 2)))))
+        (setq S1W-low (+ (/ W-high (, (/ 65536 2)))
+                         (% (* W-low 2) 65536))))))
+  (defmacro sha1-S5  (A-high A-low)
+    (` (progn
+        (setq S5A-high (+ (% (* (, A-high) 32) 65536)
+                          (/ (, A-low) (, (/ 65536 32)))))
+        (setq S5A-low  (+ (/ (, A-high) (, (/ 65536 32)))
+                          (% (* (, A-low) 32) 65536))))))
+  (defmacro sha1-S30 (B-high B-low)
+    (` (progn
+        (setq S30B-high (+ (/ (, B-high) 4)
+                           (* (% (, B-low) 4) (, (/ 65536 4)))))
+        (setq S30B-low  (+ (/ (, B-low) 4)
+                           (* (% (, B-high) 4) (, (/ 65536 4))))))))
+
+  (defmacro sha1-OP (round)
+    (` (progn
+        (sha1-S5 sha1-A-high sha1-A-low)
+        (sha1-S30 sha1-B-high sha1-B-low)
+        (setq sha1-A-low (+ ((, (intern (format "sha1-F%d" round)))
+                             sha1-B-low sha1-C-low sha1-D-low)
+                            sha1-E-low
+                            (, (symbol-value
+                                (intern (format "sha1-K%d-low" round))))
+                            (aref block-low idx)
+                            (progn
+                              (setq sha1-E-low sha1-D-low)
+                              (setq sha1-D-low sha1-C-low)
+                              (setq sha1-C-low S30B-low)
+                              (setq sha1-B-low sha1-A-low)
+                              S5A-low)))
+        (setq carry (/ sha1-A-low 65536))
+        (setq sha1-A-low (% sha1-A-low 65536))
+        (setq sha1-A-high (% (+ ((, (intern (format "sha1-F%d" round)))
+                                 sha1-B-high sha1-C-high sha1-D-high)
+                                sha1-E-high
+                                (, (symbol-value
+                                    (intern (format "sha1-K%d-high" round))))
+                                (aref block-high idx)
+                                (progn
+                                  (setq sha1-E-high sha1-D-high)
+                                  (setq sha1-D-high sha1-C-high)
+                                  (setq sha1-C-high S30B-high)
+                                  (setq sha1-B-high sha1-A-high)
+                                  S5A-high)
+                                carry)
+                             65536)))))
+
+  (defmacro sha1-add-to-H (H X)
+    (` (progn
+        (setq (, (intern (format "sha1-%s-low" H)))
+              (+ (, (intern (format "sha1-%s-low" H)))
+                 (, (intern (format "sha1-%s-low" X)))))
+        (setq carry (/ (, (intern (format "sha1-%s-low" H))) 65536))
+        (setq (, (intern (format "sha1-%s-low" H)))
+              (% (, (intern (format "sha1-%s-low" H))) 65536))
+        (setq (, (intern (format "sha1-%s-high" H)))
+              (% (+ (, (intern (format "sha1-%s-high" H)))
+                    (, (intern (format "sha1-%s-high" X)))
+                    carry)
+                 65536)))))
+  )
+
+;;; buffers (H0 H1 H2 H3 H4).
+(defvar sha1-H0-high)
+(defvar sha1-H0-low)
+(defvar sha1-H1-high)
+(defvar sha1-H1-low)
+(defvar sha1-H2-high)
+(defvar sha1-H2-low)
+(defvar sha1-H3-high)
+(defvar sha1-H3-low)
+(defvar sha1-H4-high)
+(defvar sha1-H4-low)
+
+(defun sha1-block (block-high block-low)
+  (let (;; step (c) --- initialize buffers (A B C D E).
+       (sha1-A-high sha1-H0-high) (sha1-A-low sha1-H0-low)
+       (sha1-B-high sha1-H1-high) (sha1-B-low sha1-H1-low)
+       (sha1-C-high sha1-H2-high) (sha1-C-low sha1-H2-low)
+       (sha1-D-high sha1-H3-high) (sha1-D-low sha1-H3-low)
+       (sha1-E-high sha1-H4-high) (sha1-E-low sha1-H4-low)
+       (idx 16))
+    ;; step (b).
+    (let (;; temporary variables used in sha1-S1 macro.
+         S1W-high S1W-low)
+      (while (< idx 80)
+       (sha1-S1 (logxor (aref block-high (- idx 3))
+                        (aref block-high (- idx 8))
+                        (aref block-high (- idx 14))
+                        (aref block-high (- idx 16)))
+                (logxor (aref block-low  (- idx 3))
+                        (aref block-low  (- idx 8))
+                        (aref block-low  (- idx 14))
+                        (aref block-low  (- idx 16))))
+       (aset block-high idx S1W-high)
+       (aset block-low  idx S1W-low)
+       (setq idx (1+ idx))))
+    ;; step (d).
+    (setq idx 0)
+    (let (;; temporary variables used in sha1-OP macro.
+         S5A-high S5A-low S30B-high S30B-low carry)
+      (while (< idx 20) (sha1-OP 0) (setq idx (1+ idx)))
+      (while (< idx 40) (sha1-OP 1) (setq idx (1+ idx)))
+      (while (< idx 60) (sha1-OP 2) (setq idx (1+ idx)))
+      (while (< idx 80) (sha1-OP 3) (setq idx (1+ idx))))
+    ;; step (e).
+    (let (;; temporary variables used in sha1-add-to-H macro.
+         carry)
+      (sha1-add-to-H H0 A)
+      (sha1-add-to-H H1 B)
+      (sha1-add-to-H H2 C)
+      (sha1-add-to-H H3 D)
+      (sha1-add-to-H H4 E))))
+
+(defun sha1-binary (string)
+  "Return the SHA1 of STRING in binary form."
+  (let (;; prepare buffers for a block. byte-length of block is 64.
+       ;; input block is split into two vectors.
+       ;;
+       ;; input block: 00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F ...
+       ;; block-high:  +-0-+       +-1-+       +-2-+       +-3-+
+       ;; block-low:         +-0-+       +-1-+       +-2-+       +-3-+
+       ;;
+       ;; length of each vector is 80, and elements of each vector are
+       ;; 16bit integers.  elements 0x10-0x4F of each vector are
+       ;; assigned later in `sha1-block'.
+       (block-high (eval-when-compile (make-vector 80 nil)))
+       (block-low  (eval-when-compile (make-vector 80 nil))))
+    (unwind-protect
+       (let* (;; byte-length of input string.
+              (len (length string))
+              (lim (* (/ len 64) 64))
+              (rem (% len 4))
+              (idx 0)(pos 0))
+         ;; initialize buffers (H0 H1 H2 H3 H4).
+         (setq sha1-H0-high 26437      ; (string-to-number "6745" 16)
+               sha1-H0-low  8961       ; (string-to-number "2301" 16)
+               sha1-H1-high 61389      ; (string-to-number "EFCD" 16)
+               sha1-H1-low  43913      ; (string-to-number "AB89" 16)
+               sha1-H2-high 39098      ; (string-to-number "98BA" 16)
+               sha1-H2-low  56574      ; (string-to-number "DCFE" 16)
+               sha1-H3-high 4146       ; (string-to-number "1032" 16)
+               sha1-H3-low  21622      ; (string-to-number "5476" 16)
+               sha1-H4-high 50130      ; (string-to-number "C3D2" 16)
+               sha1-H4-low  57840)     ; (string-to-number "E1F0" 16)
+         ;; loop for each 64 bytes block.
+         (while (< pos lim)
+           ;; step (a).
+           (setq idx 0)
+           (while (< idx 16)
+             (aset block-high idx (+ (* (aref string pos) 256)
+                                     (aref string (1+ pos))))
+             (setq pos (+ pos 2))
+             (aset block-low  idx (+ (* (aref string pos) 256)
+                                     (aref string (1+ pos))))
+             (setq pos (+ pos 2))
+             (setq idx (1+ idx)))
+           (sha1-block block-high block-low))
+         ;; last block.
+         (if (prog1
+                 (< (- len lim) 56)
+               (setq lim (- len rem))
+               (setq idx 0)
+               (while (< pos lim)
+                 (aset block-high idx (+ (* (aref string pos) 256)
+                                         (aref string (1+ pos))))
+                 (setq pos (+ pos 2))
+                 (aset block-low  idx (+ (* (aref string pos) 256)
+                                         (aref string (1+ pos))))
+                 (setq pos (+ pos 2))
+                 (setq idx (1+ idx)))
+               ;; this is the last (at most) 32bit word.
+               (cond
+                ((= rem 3)
+                 (aset block-high idx (+ (* (aref string pos) 256)
+                                         (aref string (1+ pos))))
+                 (setq pos (+ pos 2))
+                 (aset block-low  idx (+ (* (aref string pos) 256)
+                                         128)))
+                ((= rem 2)
+                 (aset block-high idx (+ (* (aref string pos) 256)
+                                         (aref string (1+ pos))))
+                 (aset block-low  idx 32768))
+                ((= rem 1)
+                 (aset block-high idx (+ (* (aref string pos) 256)
+                                         128))
+                 (aset block-low  idx 0))
+                (t ;; (= rem 0)
+                 (aset block-high idx 32768)
+                 (aset block-low  idx 0)))
+               (setq idx (1+ idx))
+               (while (< idx 16)
+                 (aset block-high idx 0)
+                 (aset block-low  idx 0)
+                 (setq idx (1+ idx))))
+             ;; last block has enough room to write the length of string.
+             (progn
+               ;; write bit length of string to last 4 bytes of the block.
+               (aset block-low  15 (* (% len 8192) 8))
+               (setq len (/ len 8192))
+               (aset block-high 15 (% len 65536))
+               ;; XXX: It is not practical to compute SHA1 of
+               ;;      such a huge message on emacs.
+               ;; (setq len (/ len 65536))     ; for 64bit emacs.
+               ;; (aset block-low  14 (% len 65536))
+               ;; (aset block-high 14 (/ len 65536))
+               (sha1-block block-high block-low))
+           ;; need one more block.
+           (sha1-block block-high block-low)
+           (fillarray block-high 0)
+           (fillarray block-low  0)
+           ;; write bit length of string to last 4 bytes of the block.
+           (aset block-low  15 (* (% len 8192) 8))
+           (setq len (/ len 8192))
+           (aset block-high 15 (% len 65536))
+           ;; XXX: It is not practical to compute SHA1 of
+           ;;      such a huge message on emacs.
+           ;; (setq len (/ len 65536))         ; for 64bit emacs.
+           ;; (aset block-low  14 (% len 65536))
+           ;; (aset block-high 14 (/ len 65536))
+           (sha1-block block-high block-low))
+         ;; make output string (in binary form).
+         (let ((result (make-string 20 0)))
+           (aset result  0 (/ sha1-H0-high 256))
+           (aset result  1 (% sha1-H0-high 256))
+           (aset result  2 (/ sha1-H0-low  256))
+           (aset result  3 (% sha1-H0-low  256))
+           (aset result  4 (/ sha1-H1-high 256))
+           (aset result  5 (% sha1-H1-high 256))
+           (aset result  6 (/ sha1-H1-low  256))
+           (aset result  7 (% sha1-H1-low  256))
+           (aset result  8 (/ sha1-H2-high 256))
+           (aset result  9 (% sha1-H2-high 256))
+           (aset result 10 (/ sha1-H2-low  256))
+           (aset result 11 (% sha1-H2-low  256))
+           (aset result 12 (/ sha1-H3-high 256))
+           (aset result 13 (% sha1-H3-high 256))
+           (aset result 14 (/ sha1-H3-low  256))
+           (aset result 15 (% sha1-H3-low  256))
+           (aset result 16 (/ sha1-H4-high 256))
+           (aset result 17 (% sha1-H4-high 256))
+           (aset result 18 (/ sha1-H4-low  256))
+           (aset result 19 (% sha1-H4-low  256))
+           result))
+      ;; do not leave a copy of input string.
+      (fillarray block-high nil)
+      (fillarray block-low  nil))))
+
+(defun sha1-string-internal (string)
+  (encode-hex-string (sha1-binary string)))
+
+(defun sha1-region-internal (beg end)
+  (sha1-string-internal (buffer-substring-no-properties beg end)))
+
+;;;
+;;; application interface.
+;;;
+
+(defun sha1-region (beg end)
+  (if (and sha1-maximum-internal-length
+          (> (abs (- end beg)) sha1-maximum-internal-length))
+      (sha1-region-external beg end)
+    (sha1-region-internal beg end)))
+
+(defun sha1-string (string)
+  (if (and sha1-maximum-internal-length
+          (> (length string) sha1-maximum-internal-length))
+      (sha1-string-external string)
+    (sha1-string-internal string)))
+
+(defun sha1 (object &optional beg end)
+  "Return the SHA1 (Secure Hash Algorithm) of an object.
+OBJECT is either a string or a buffer.
+Optional arguments BEG and END denote buffer positions for computing the
+hash of a portion of OBJECT."
+  (if (stringp object)
+      (sha1-string object)
+    (save-excursion
+      (set-buffer object)
+      (sha1-region (or beg (point-min)) (or end (point-max))))))
+
+(provide 'sha1-el)
+
+;;; sha1-el.el ends here
index ddd8c0f..a9a4306 100644 (file)
@@ -1,3 +1,8 @@
+2001-10-31  Katsumi Yamaoka  <yamaoka@jpl.org>
+
+       * gnus.texi (NNTP): Added documentation for
+       `nntp-prepare-post-hook'.
+       
 2001-10-29  Simon Josefsson  <jas@extundo.com>
 
        * gnus.texi (Customizing Articles): Sort list. Remove
index e6d1d99..05a8235 100644 (file)
@@ -10763,6 +10763,19 @@ default force yes
 \e$B$5$l$F$$$^$9!#$=$l$i$OFs<oN`$KJ,N`$9$k$3$H$,$G$-!"D>@\@\B3$9$k$?$a$N4X?t\e(B
 \e$B72\e(B (\e$B;0$D\e(B) \e$B$H4V@\E*$K@\B3$9$k$?$a$N$b$N\e(B (\e$BFs$D\e(B) \e$B$,$"$j$^$9!#\e(B
 
+@item nntp-prepare-post-hook
+@vindex nntp-prepare-post-hook
+\e$B5-;v$r%]%9%H$9$kD>A0$K<B9T$5$l$k%U%C%/$G$9!#$b$75-;v\e(B
+\e$B$K\e(B @code{Message-ID} \e$B%X%C%@!<$,L5$/$F%K%e!<%9%5!<%P!<$,?d>)\e(B ID \e$B$rDs6!$7\e(B
+\e$B$F$/$l$k$J$i$P!"$3$N%U%C%/$,<B9T$5$l$kA0$K$=$l$,5-;v$K2C$($i$l$^$9!#$3$l\e(B
+\e$B$O!"$b$7$"$J$?$,\e(B gnus \e$B$,\e(B @code{Message-ID} \e$B%X%C%@!<$rIU$1$J$$$h$&$K$7$F\e(B
+\e$B$$$F$b!"\e(B@code{Cancel-Lock} \e$B%X%C%@!<$r:n$k$?$a$KMxMQ$9$k$3$H$,$G$-$^$9!#\e(B
+\e$B$=$l$K$O$3$&$9$l$PNI$$$G$7$g$&\e(B:
+
+@lisp
+(add-hook 'nntp-prepare-post-hook 'canlock-insert-header)
+@end lisp
+
 @item nntp-list-options
 @vindex nntp-list-options
 LIST \e$B%3%^%s%I$N%*%W%7%g%s$K;H$C$F!"\e(B(\e$B%5!<%P!<$N\e(B) \e$B%j%9%H=PNO$r@_Dj$7$?%K%e!<\e(B
index fdfb455..9711151 100644 (file)
@@ -11305,6 +11305,18 @@ Five pre-made functions are supplied.  These functions can be grouped in
 two categories: direct connection functions (three pre-made), and
 indirect ones (two pre-made).
 
+@item nntp-prepare-post-hook
+@vindex nntp-prepare-post-hook
+A hook run just before posting an article.  If there is no
+@code{Message-ID} header in the article and the news server provides the
+recommended ID, it will be added to the article before running this
+hook.  It is useful to make @code{Cancel-Lock} headers even if you
+inhibit Gnus to add a @code{Message-ID} header, you could say:
+
+@lisp
+(add-hook 'nntp-prepare-post-hook 'canlock-insert-header)
+@end lisp
+
 @item nntp-list-options
 @vindex nntp-list-options
 List of newsgroup name used for a option of the LIST command to restrict