--- /dev/null
+;;; canlock.el --- Functions for Cancel-Lock feature.
+;; Copyright (C) 1998,1999 Katsumi Yamaoka
+
+;; Author: Katsumi Yamaoka <yamaoka@jpl.org>
+;; Yuuichi Teranishi <teranisi@gohome.org>
+;; Hideyuki SHIRAI <shirai@rdmg.mgcs.mei.co.jp>
+;; Hidekazu Nakamura <u90121@uis-inf.co.jp>
+;; Ken'ichi Okada <kokada@tamaru.kuee.kyoto-u.ac.jp>
+;; Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
+;; Created: 1998-11-24
+;; Revised: 1999-06-14
+;; Keywords: news, cancel-lock, hmac, sha1, rfc2104
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, write to the Free Software
+;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+;; USA.
+
+;;; Commentary:
+
+;; This library is based on draft-ietf-usefor-cancel-lock-01.txt,
+;; released on 1998-11-03.
+
+;;; Code:
+
+(defconst canlock-version "0.6")
+
+(eval-when-compile (require 'cl))
+(require 'custom)
+(require 'mail-utils)
+
+(autoload 'sha1-encode-binary "sha1")
+(autoload 'base64-encode "base64")
+
+(defgroup canlock nil
+ "Cancel-Lock feature."
+ :prefix "canlock-"
+ :group 'applications)
+
+(defcustom canlock-base64-encode-function 'base64-encode-string
+ "*Function called to encode string to base64."
+ :type '(radio (function-item base64-encode-string)
+ (function-item base64-encode)
+ (function-item canlock-base64-encode-string-with-mmencode)
+ (function :tag "Other"))
+ :group 'canlock)
+
+(defcustom canlock-mmencode-program "mmencode"
+ "*Name of mmencode program."
+ :type 'string
+ :group 'canlock)
+
+(defcustom canlock-mmencode-args-for-encoding nil
+ "*Arguments passed to mmencode program for encoding."
+ :type 'sexp
+ :group 'canlock)
+
+(defcustom canlock-sha1-function 'sha1-encode-binary
+ "*Function called to make a SHA1 digest from a message (string)."
+ :type '(radio (function-item sha1-encode-binary)
+ (function-item canlock-sha1-with-ssleay)
+ (function :tag "Other"))
+ :group 'canlock)
+
+(defcustom canlock-sha1-function-for-verify canlock-sha1-function
+ "*Function called to make a SHA1 digest for verifying."
+ :type '(radio (function-item sha1-encode-binary)
+ (function-item canlock-sha1-with-ssleay)
+ (function :tag "Other"))
+ :group 'canlock)
+
+(defcustom canlock-ssleay-program "ssleay"
+ "*Name of SSLeay program."
+ :type 'string
+ :group 'canlock)
+
+(defcustom canlock-ssleay-args '("sha1")
+ "*Arguments passed to SSLeay program."
+ :type 'sexp
+ :group 'canlock)
+
+(defcustom canlock-ignore-errors nil
+ "*If non-nil, ignore any error signals."
+ :type 'boolean
+ :group 'canlock)
+
+(defcustom canlock-load-hook nil
+ "*Hook to be run after the canlock package has been loaded."
+ :type 'hook
+ :group 'canlock)
+
+;;; Internal variables.
+
+(defvar canlock-password nil
+ "*Password to use when signing a Cancel-Lock or a Cancel-Key header.")
+
+(defvar canlock-password-for-verify canlock-password
+ "*Password to use when verifying a Cancel-Lock or a Cancel-Key header.")
+
+(defvar canlock-force-insert-header nil
+ "*If non-nil, insert a Cancel-Lock or a Cancel-Key header even though the
+buffer does not contain a news message.")
+
+;;; Functions.
+
+(defun canlock-base64-encode-string-with-mmencode (string)
+ "Encode string to base64 with mmencode."
+ (with-temp-buffer
+ (let ((coding-system-for-read 'raw-text)
+ (coding-system-for-write 'binary)
+ ;; For Mule 2 with APEL 9.12 or later.
+ (default-process-coding-system '(raw-text . binary))
+ mc-flag program-coding-system-alist)
+ (insert string)
+ (apply 'call-process-region (point-min) (point-max)
+ canlock-mmencode-program t t nil
+ canlock-mmencode-args-for-encoding)
+ (goto-char (point-max))
+ (skip-chars-backward "\n")
+ (buffer-substring (point-min) (point)))))
+
+(defun canlock-hex-string-to-int (string)
+ "Convert hexadecimal string to integer."
+ (let ((integer 0))
+ (mapcar
+ (lambda (hex)
+ (setq integer (+ (* 16 integer)
+ (logand hex 15)
+ (* (lsh hex -6) 9))))
+ string)
+ integer))
+
+(defun canlock-sha1-with-ssleay (message)
+ "Make a SHA1 digest from a specified message (string) with SSLeay."
+ (with-temp-buffer
+ (let ((coding-system-for-read 'binary)
+ (coding-system-for-write 'binary)
+ ;; For Mule 2 with APEL 9.12 or later.
+ (default-process-coding-system '(binary . binary))
+ mc-flag program-coding-system-alist
+ (case-fold-search t))
+ (insert message)
+ (apply 'call-process-region (point-min) (point-max)
+ canlock-ssleay-program t t nil canlock-ssleay-args)
+ (goto-char (point-min))
+ (while (re-search-forward "[0-9A-F][0-9A-F]" nil t)
+ (goto-char (match-beginning 0))
+ (insert-char (canlock-hex-string-to-int (match-string 0)) 1)
+ (delete-char 2))
+ (buffer-substring (point-min) (point)))))
+
+(defvar canlock-read-passwd nil)
+(defun canlock-read-passwd (prompt &rest args)
+ "Read a password using PROMPT.
+If ARGS, PROMPT is used as an argument to `format'."
+ (let ((prompt
+ (if args
+ (apply 'format prompt args)
+ prompt)))
+ (unless canlock-read-passwd
+ (if (or (fboundp 'read-passwd) (load "passwd" t))
+ (setq canlock-read-passwd 'read-passwd)
+ (unless (fboundp 'ange-ftp-read-passwd)
+ (autoload 'ange-ftp-read-passwd "ange-ftp"))
+ (setq canlock-read-passwd 'ange-ftp-read-passwd)))
+ (funcall canlock-read-passwd prompt)))
+
+(defun canlock-make-cancel-key (message-id password)
+ "Make a Cancel-Key header."
+ (cond ((> (length password) 20)
+ (setq password (funcall canlock-sha1-function password)))
+ ((< (length password) 20)
+ (setq password (concat
+ password
+ (make-string (- 20 (length password)) 0)))))
+ (setq password (concat password (make-string 44 0)))
+ (let ((ipad (mapconcat (lambda (char)
+ (char-to-string (logxor 54 char)))
+ password ""))
+ (opad (mapconcat (lambda (char)
+ (char-to-string (logxor 92 char)))
+ password "")))
+ (funcall canlock-base64-encode-function
+ (funcall canlock-sha1-function
+ (concat
+ opad
+ (funcall canlock-sha1-function
+ (concat ipad message-id)))))))
+
+(defun canlock-narrow-to-header ()
+ "Narrow to the message header."
+ (let (case-fold-search)
+ (narrow-to-region
+ (goto-char (point-min))
+ (goto-char (if (re-search-forward
+ (format "^$\\|^%s$"
+ (regexp-quote mail-header-separator))
+ nil t)
+ (match-beginning 0)
+ (point-max))))))
+
+(defun canlock-delete-headers ()
+ "Delete Canlock headers if they already exist.
+The buffer is expected to be narrowed to just the headers of the message."
+ (let ((case-fold-search t))
+ (goto-char (point-min))
+ (while (re-search-forward "^Cancel-\\(Key\\|Lock\\):" nil t)
+ (delete-region (match-beginning 0)
+ (if (re-search-forward "^[^\t ]" nil t)
+ (goto-char (match-beginning 0))
+ (point-max))))))
+
+(defun canlock-fetch-fields (&optional key)
+ "Return the list of values of Cancel-Lock field.
+If the optional arg KEY is non-nil, Cancel-Key field will be fetched.
+The buffer is expected to be narrowed to just the headers of the message."
+ (let ((feild (mail-fetch-field (if key "Cancel-Key" "Cancel-Lock")))
+ (case-fold-search t))
+ (when feild
+ (mapcar (lambda (str)
+ (string-match "^sha1:" str)
+ (substring str (match-end 0)))
+ (split-string feild "[\t\n\r ,]+")))))
+
+(defun canlock-fetch-id-for-key ()
+ "Return the Message-ID for Cancel-Key.
+The buffer is expected to be narrowed to just the headers of the message."
+ (let ((cancel (mail-fetch-field "Control")))
+ (if cancel
+ (progn
+ (string-match "^cancel[\t ]+\\(<[^\t\n @<>]+@[^\t\n @<>]+>\\)"
+ cancel)
+ (match-string 1 cancel))
+ (or (mail-fetch-field "Supersedes")
+ (mail-fetch-field "Replaces")))))
+
+;;;###autoload
+(defun canlock-insert-header (&optional id-for-key id-for-lock password)
+ "Insert a Cancel-Key and/or a Cancel-Lock header if possible."
+ (let (news control key-for-key key-for-lock)
+ (save-excursion
+ (save-restriction
+ (canlock-narrow-to-header)
+ (when (setq news (or canlock-force-insert-header
+ (mail-fetch-field "Newsgroups")))
+ (unless id-for-key
+ (setq id-for-key (canlock-fetch-id-for-key)))
+ (if (and (setq control (mail-fetch-field "Control"))
+ (string-match
+ "^cancel[\t ]+\\(<[^\t\n @<>]+@[^\t\n @<>]+>\\)"
+ control))
+ (setq id-for-lock nil)
+ (unless id-for-lock
+ (setq id-for-lock (mail-fetch-field "Message-ID"))))
+ (canlock-delete-headers)
+ (goto-char (point-max))))
+ (when news
+ (if (not (or id-for-key id-for-lock))
+ (message "There are no Message-ID(s).")
+ (unless password
+ (setq password (or canlock-password
+ (canlock-read-passwd
+ "Password for Canlock: "))))
+ (if (or (not (stringp password)) (zerop (length password)))
+ (message "Password for Canlock is bad.")
+ (setq key-for-key (when id-for-key
+ (canlock-make-cancel-key
+ id-for-key password))
+ key-for-lock (when id-for-lock
+ (canlock-make-cancel-key
+ id-for-lock password)))
+ (if (not (or key-for-key key-for-lock))
+ (message "Couldn't insert Canlock header.")
+ (when key-for-key
+ (insert "Cancel-Key: sha1:" key-for-key "\n"))
+ (when key-for-lock
+ (insert "Cancel-Lock: sha1:"
+ (funcall canlock-base64-encode-function
+ (funcall canlock-sha1-function
+ key-for-lock))
+ "\n")))))))))
+
+;;;###autoload
+(defun canlock-verify (&optional buffer)
+ "Verify Cancel-Lock or Cancel-Key. If failed, returns non-nil or signals
+an error if `canlock-ignore-errors' is nil. If the optional arg BUFFER
+is not specified, it runs in place."
+ (interactive)
+ (let ((canlock-sha1-function (or canlock-sha1-function-for-verify
+ canlock-sha1-function))
+ keys locks errmsg id-for-key id-for-lock password
+ key-for-key key-for-lock match)
+ (save-excursion
+ (when buffer
+ (set-buffer buffer))
+ (save-restriction
+ (widen)
+ (canlock-narrow-to-header)
+ (setq keys (canlock-fetch-fields 'key)
+ locks (canlock-fetch-fields))
+ (if (not (or keys locks))
+ (setq errmsg
+ "There are neither Cancel-Lock nor Cancel-Key fields.")
+ (setq id-for-key (canlock-fetch-id-for-key)
+ id-for-lock (mail-fetch-field "Message-ID"))
+ (or id-for-key id-for-lock
+ (setq errmsg "There are no Message-ID(s).")))))
+
+ (if errmsg
+ (if canlock-ignore-errors
+ errmsg
+ (error "%s" errmsg))
+
+ (setq password (or canlock-password-for-verify
+ (canlock-read-passwd "Password for Canlock: ")))
+ (if (or (not (stringp password)) (zerop (length password)))
+ (progn
+ (setq errmsg "Password for Canlock is bad.")
+ (if canlock-ignore-errors
+ errmsg
+ (error "%s" errmsg)))
+
+ (when keys
+ (when id-for-key
+ (setq key-for-key (canlock-make-cancel-key id-for-key password))
+ (while (and keys (not match))
+ (setq match (string-equal key-for-key (pop keys)))))
+ (setq keys (if match "good" "bad")))
+ (setq match nil)
+
+ (when locks
+ (when id-for-lock
+ (setq key-for-lock
+ (funcall canlock-base64-encode-function
+ (funcall canlock-sha1-function
+ (canlock-make-cancel-key
+ id-for-lock password))))
+ (when (and locks (not match))
+ (setq match (string-equal key-for-lock (pop locks)))))
+ (setq locks (if match "good" "bad")))
+
+ (prog1
+ (when (member "bad" (list keys locks))
+ "bad")
+ (cond ((and keys locks)
+ (message "Cancel-Key is %s, Cancel-Lock is %s." keys locks))
+ (locks
+ (message "Cancel-Lock is %s." locks))
+ (keys
+ (message "Cancel-Key is %s." keys))))))))
+
+;; Avoid byte compile warnings.
+(defvar gnus-show-all-headers)
+(defvar gnus-original-article-buffer)
+(defvar mh-show-buffer)
+(defvar vm-mail-buffer)
+(defvar vm-message-pointer)
+(defvar cmail-current-folder)
+(defvar rmail-buffer)
+
+;;;###autoload
+(defun gnus-summary-canlock-verify ()
+ "Run `canlock-verify' from gnus summary buffer."
+ (interactive)
+ (gnus-summary-select-article gnus-show-all-headers)
+ (canlock-verify gnus-original-article-buffer))
+
+;;;###autoload
+(defun wl-summary-canlock-verify ()
+ "Run `canlock-verify' from Wanderlust summary buffer."
+ (interactive)
+ (wl-summary-set-message-buffer-or-redisplay)
+ (canlock-verify (wl-message-get-original-buffer)))
+
+(eval-when-compile
+ (if (or (featurep 'use-mew-1.94b20-or-later)
+ (and (fboundp 'function-max-args)
+ (or (fboundp 'mew-summary-display)
+ (load "mew-summary" t))
+ (eq 2 (function-max-args 'mew-summary-display))))
+ (progn
+ (defmacro canlock-mew-summary-display ()
+ '(mew-summary-display t))
+ (message "Use mew-1.94b20 or later."))
+ (defmacro canlock-mew-summary-display ()
+ '(condition-case nil
+ (mew-summary-display)
+ (wrong-number-of-arguments
+ (mew-summary-display t))))
+ ))
+
+;;;###autoload
+(defun mew-summary-canlock-verify ()
+ "Run `canlock-verify' from Mew summary buffer."
+ (interactive)
+ (canlock-mew-summary-display)
+ (canlock-verify (mew-buffer-message)))
+
+;;;###autoload
+(defun mh-summary-canlock-verify ()
+ "Run `canlock-verify' from MH folder buffer."
+ (interactive)
+ (mh-header-display)
+ (canlock-verify mh-show-buffer))
+
+;;;###autoload
+(defun vm-summary-canlock-verify ()
+ "Run `canlock-verify' from VM summary buffer."
+ (interactive)
+ (vm-follow-summary-cursor)
+ (if (and vm-mail-buffer (buffer-name vm-mail-buffer))
+ (save-excursion
+ (set-buffer vm-mail-buffer)
+ (let* ((mp (car vm-message-pointer))
+ (header (save-restriction
+ (widen)
+ (buffer-substring
+ (aref (aref mp 0) 0) (vm-text-of mp)))))
+ (with-temp-buffer
+ (insert header)
+ (canlock-verify))))
+ (or canlock-ignore-errors
+ (error "Folder buffer has been killed."))))
+
+;;;###autoload
+(defun cmail-summary-canlock-verify ()
+ "Run `canlock-verify' from cmail summary buffer."
+ (interactive)
+ (let* ((page (cmail-get-page-number-from-summary))
+ (header (save-excursion
+ (set-buffer (cmail-folder-buffer cmail-current-folder))
+ (cmail-n-page page)
+ (buffer-substring (point)
+ (if (search-forward "\n\n" nil t)
+ (1- (point))
+ (point-max))))))
+ (with-temp-buffer
+ (insert header)
+ (canlock-verify))))
+
+;;;###autoload
+(defun rmail-summary-canlock-verify ()
+ "Run `canlock-verify' from RMAIL summary buffer."
+ (interactive)
+ (rmail-summary-rmail-update)
+ (let ((header (save-excursion
+ (set-buffer rmail-buffer)
+ (goto-char (point-min))
+ (save-restriction
+ (widen)
+ (search-backward "\n\C-_\C-l\n") ;; ^_^L
+ (re-search-forward "^[^\t\n ]+:")
+ (buffer-substring
+ (goto-char (match-beginning 0))
+ (progn (search-forward "\n\n")
+ (1- (point))))))))
+ (with-temp-buffer
+ (insert header)
+ (canlock-verify))))
+
+(provide 'canlock)
+
+(run-hooks 'canlock-load-hook)
+
+;;; canlock.el ends here
--- /dev/null
+;;; sha1.el --- SHA1 Message Digest Algorithm.
+;; Copyright (C) 1998,1999 Keiichi Suzuki.
+
+;; Author: Keiichi Suzuki <kei-suzu@mail.wbs.ne.jp>
+;; Author: Katsumi Yamaoka <yamaoka@jpl.org>
+;; Created: 1998-12-25
+;; Revised: 1999-01-13
+;; Keywords: sha1, news, cancel-lock, hmac, rfc2104
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;;; A copy of the GNU General Public License can be obtained from this
+;;; program's author (send electronic mail to kyle@uunet.uu.net) or from
+;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
+;;; 02139, USA.
+
+;;; Commentary:
+
+;; This is a direct translation into Emacs LISP of the reference C
+;; implementation of the SHA1 message digest algorithm.
+
+;;; Usage:
+
+;; To compute the SHA1 message digest for a message M (represented as
+;; a string), call
+;;
+;; (sha1-encode M)
+;;
+;; which returns the message digest as a hexadecimal string of 20 bytes.
+;; If you need to supply the message in pieces M1, M2, ... Mn, then call
+;;
+;; (sha1-init)
+;; (sha1-update M1)
+;; (sha1-update M2)
+;; ...
+;; (sha1-update Mn)
+;; (sha1-final)
+
+;;; Notes:
+
+;; The C algorithm uses 32-bit integers; because GNU Emacs
+;; implementations provide 28-bit integers (with 24-bit integers on
+;; versions prior to 19.29), the code represents a 32-bit integer as the
+;; cons of two 16-bit integers. The most significant word is stored in
+;; the car and the least significant in the cdr. The algorithm requires
+;; at least 19 bits of integer representation in order to represent the
+;; carry from a 16-bit addition. (see sha1-add())
+
+;;; Code:
+
+(defmacro sha1-f1 (x y z)
+ `(cons
+ (logior (logand (car ,x) (car ,y)) (logand (lognot (car ,x)) (car ,z)))
+ (logior (logand (cdr ,x) (cdr ,y)) (logand (lognot (cdr ,x)) (cdr ,z)))
+ ))
+
+(defmacro sha1-f2 (x y z)
+ `(cons
+ (logxor (car ,x) (car ,y) (car ,z))
+ (logxor (cdr ,x) (cdr ,y) (cdr ,z))
+ ))
+
+(defmacro sha1-f3 (x y z)
+ `(cons
+ (logior (logand (car ,x) (car ,y)) (logand (car ,x) (car ,z))
+ (logand (car ,y) (car ,z)))
+ (logior (logand (cdr ,x) (cdr ,y)) (logand (cdr ,x) (cdr ,z))
+ (logand (cdr ,y) (cdr ,z)))
+ ))
+
+(defmacro sha1-f4 (x y z)
+ `(cons
+ (logxor (car ,x) (car ,y) (car ,z))
+ (logxor (cdr ,x) (cdr ,y) (cdr ,z))
+ ))
+
+(defconst sha1-const1 '(23170 . 31129)
+ "SHA constants 1 \(0x5a827999\)")
+(defconst sha1-const2 '(28377 . 60321)
+ "SHA constants 2 \(0x6ed9eba1\)")
+(defconst sha1-const3 '(36635 . 48348)
+ "SHA constants 3 \(0x8f1bbcdc\)")
+(defconst sha1-const4 '(51810 . 49622)
+ "SHA constants 4 \(0xca62c1d6\)")
+
+(defvar sha1-digest (make-vector 5 nil))
+(defvar sha1-count-lo nil)
+(defvar sha1-count-hi nil)
+(defvar sha1-data nil)
+(defvar sha1-local nil)
+(defconst SHA1-BLOCKSIZE 64)
+
+(defun sha1-init ()
+ "Initialize the state of the SHA1 message digest routines."
+ (aset sha1-digest 0 (cons 26437 8961))
+ (aset sha1-digest 1 (cons 61389 43913))
+ (aset sha1-digest 2 (cons 39098 56574))
+ (aset sha1-digest 3 (cons 4146 21622))
+ (aset sha1-digest 4 (cons 50130 57840))
+ (setq sha1-count-lo (cons 0 0)
+ sha1-count-hi (cons 0 0)
+ sha1-local 0
+ sha1-data nil)
+ )
+
+(defmacro sha1-32-make (v)
+ "Return 32bits internal value from normal integer."
+ `(cons (lsh ,v -16) (logand 65535 ,v)))
+
+(defun sha1-add (to &rest vals)
+ "Set sum of all the arguments to the first one."
+ (let (val)
+ (while (setq val (car vals))
+ (setcar to (+ (car to) (car val)))
+ (setcdr to (+ (cdr to) (cdr val)))
+ (setq vals (cdr vals))
+ )
+ (setcar to (logand 65535 (+ (car to) (lsh (cdr to) -16))))
+ (setcdr to (logand 65535 (cdr to)))
+ to
+ ))
+
+(defun sha1-xor (to &rest vals)
+ "Set bitwise-exclusive-or of all the arguments to the first one."
+ (let (val)
+ (while (setq val (car vals))
+ (setcar to (logxor (car to) (car val)))
+ (setcdr to (logxor (cdr to) (cdr val)))
+ (setq vals (cdr vals)))
+ ))
+
+(defmacro sha1-rot (val c1 c2)
+ "Internal macro for sha1-rot-*."
+ `(cons
+ (logand 65535 (logior (lsh (car ,val) ,c1) (lsh (cdr ,val) ,c2)))
+ (logand 65535 (logior (lsh (cdr ,val) ,c1) (lsh (car ,val) ,c2)))
+ ))
+
+(defmacro sha1-rot-1 (val)
+ "Return VAL with its bits rotated left by 1."
+ `(sha1-rot ,val 1 -15)
+ )
+
+(defmacro sha1-rot-5 (val)
+ "Return VAL with its bits rotated left by 5."
+ `(sha1-rot ,val 5 -11)
+ )
+
+(defmacro sha1-rot-30 (val)
+ "Return VAL with its bits rotated left by 30."
+ `(sha1-rot ,val -2 14)
+ )
+
+(defun sha1-inc (to)
+ "Set TO pulus one to TO."
+ (setcdr to (1+ (cdr to)))
+ (when (> (cdr to) 65535)
+ (setcdr to (logand 65535 (cdr to)))
+ (setcar to (logand 65535 (1+ (car to))))))
+
+(defun sha1-lsh (to v count)
+ "Set TO with its bits shifted left by COUNT to TO."
+ (setcar to (logand 65535
+ (logior (lsh (car v) count) (lsh (cdr v) (- count 16)))))
+ (setcdr to (logand 65535 (lsh (cdr v) count)))
+ to
+ )
+
+(defun sha1-rsh (to v count)
+ "Set TO with its bits shifted right by COUNT to TO."
+ (setq count (- 0 count))
+ (setcdr to (logand 65535
+ (logior (lsh (cdr v) count) (lsh (car v) (- count 16)))))
+ (setcar to (logand 65535 (lsh (car v) count)))
+ to
+ )
+
+(defun sha1-< (v1 v2)
+ "Return t if firast argment is less then second argument."
+ (or (< (car v1) (car v2))
+ (and (eq (car v1) (car v2))
+ (< (cdr v1) (cdr v2))))
+ )
+
+(unless (fboundp 'string-as-unibyte)
+ (defsubst string-as-unibyte (string)
+ string)
+ )
+
+(defun sha1-update (bytes)
+ "Update the current SHA1 state with BYTES (an string of uni-bytes)."
+ (setq bytes (string-as-unibyte bytes))
+ (let* ((len (length bytes))
+ (len32 (sha1-32-make len))
+ (tmp32 (cons 0 0))
+ (top 0)
+ (clo (cons 0 0))
+ i done)
+ (sha1-add clo sha1-count-lo (sha1-lsh tmp32 len32 3))
+ (when (sha1-< clo sha1-count-lo)
+ (sha1-inc sha1-count-hi))
+ (setq sha1-count-lo clo)
+ (sha1-add sha1-count-hi (sha1-rsh tmp32 len32 29))
+ (when (> (length sha1-data) 0)
+ (setq i (- SHA1-BLOCKSIZE (length sha1-data)))
+ (when (> i len)
+ (setq i len))
+ (setq sha1-data (concat sha1-data (substring bytes 0 i)))
+ (setq len (- len i)
+ top i)
+ (if (eq (length sha1-data) SHA1-BLOCKSIZE)
+ (sha1-transform)
+ (setq done t)))
+ (when (not done)
+ (while (and (not done)
+ (>= len SHA1-BLOCKSIZE))
+ (setq sha1-data (substring bytes top (+ top SHA1-BLOCKSIZE))
+ top (+ top SHA1-BLOCKSIZE)
+ len (- len SHA1-BLOCKSIZE))
+ (sha1-transform))
+ (setq sha1-data (substring bytes top (+ top len))))
+ ))
+
+(defmacro sha1-FA (n)
+ (let ((func (intern (format "sha1-f%d" n)))
+ (const (intern (format "sha1-const%d" n))))
+ `(setq T (sha1-add (cons 0 0) (sha1-rot-5 A) (,func B C D) E (aref W WIDX)
+ ,const)
+ WIDX (1+ WIDX)
+ B (sha1-rot-30 B))))
+
+(defmacro sha1-FB (n)
+ (let ((func (intern (format "sha1-f%d" n)))
+ (const (intern (format "sha1-const%d" n))))
+ `(setq E (sha1-add (cons 0 0) (sha1-rot-5 T) (,func A B C) D (aref W WIDX)
+ ,const)
+ WIDX (1+ WIDX)
+ A (sha1-rot-30 A))))
+
+(defmacro sha1-FC (n)
+ (let ((func (intern (format "sha1-f%d" n)))
+ (const (intern (format "sha1-const%d" n))))
+ `(setq D (sha1-add (cons 0 0) (sha1-rot-5 E) (,func T A B) C (aref W WIDX)
+ ,const)
+ WIDX (1+ WIDX)
+ T (sha1-rot-30 T))))
+
+(defmacro sha1-FD (n)
+ (let ((func (intern (format "sha1-f%d" n)))
+ (const (intern (format "sha1-const%d" n))))
+ `(setq C (sha1-add (cons 0 0) (sha1-rot-5 D) (,func E T A) B (aref W WIDX)
+ ,const)
+ WIDX (1+ WIDX)
+ E (sha1-rot-30 E))))
+
+(defmacro sha1-FE (n)
+ (let ((func (intern (format "sha1-f%d" n)))
+ (const (intern (format "sha1-const%d" n))))
+ `(setq B (sha1-add (cons 0 0) (sha1-rot-5 C) (,func D E T) A (aref W WIDX)
+ ,const)
+ WIDX (1+ WIDX)
+ D (sha1-rot-30 D))))
+
+(defmacro sha1-FT (n)
+ (let ((func (intern (format "sha1-f%d" n)))
+ (const (intern (format "sha1-const%d" n))))
+ `(setq A (sha1-add (cons 0 0) (sha1-rot-5 B) (,func C D E) T (aref W WIDX)
+ ,const)
+ WIDX (1+ WIDX)
+ C (sha1-rot-30 C))))
+
+(defun sha1-transform ()
+ "Basic SHA1 step. Transform sha1-digest based on sha1-data."
+ (let ((W (make-vector 80 nil))
+ (WIDX 0)
+ (bidx 0)
+ T A B C D E)
+ (while (< WIDX 16)
+ (aset W WIDX
+ (cons (logior (lsh (aref sha1-data bidx) 8)
+ (aref sha1-data (setq bidx (1+ bidx))))
+ (logior (lsh (aref sha1-data (setq bidx (1+ bidx))) 8)
+ (aref sha1-data (setq bidx (1+ bidx))))))
+ (setq bidx (1+ bidx)
+ WIDX (1+ WIDX)))
+ (while (< WIDX 80)
+ (aset W WIDX (cons 0 0))
+ (sha1-xor (aref W WIDX)
+ (aref W (- WIDX 3)) (aref W (- WIDX 8))
+ (aref W (- WIDX 14)) (aref W (- WIDX 16)))
+ (aset W WIDX (sha1-rot-1 (aref W WIDX)))
+ (setq WIDX (1+ WIDX)))
+ (setq A (cons (car (aref sha1-digest 0)) (cdr (aref sha1-digest 0)))
+ B (cons (car (aref sha1-digest 1)) (cdr (aref sha1-digest 1)))
+ C (cons (car (aref sha1-digest 2)) (cdr (aref sha1-digest 2)))
+ D (cons (car (aref sha1-digest 3)) (cdr (aref sha1-digest 3)))
+ E (cons (car (aref sha1-digest 4)) (cdr (aref sha1-digest 4)))
+ WIDX 0)
+
+ (sha1-FA 1) (sha1-FB 1) (sha1-FC 1) (sha1-FD 1) (sha1-FE 1) (sha1-FT 1)
+ (sha1-FA 1) (sha1-FB 1) (sha1-FC 1) (sha1-FD 1) (sha1-FE 1) (sha1-FT 1)
+ (sha1-FA 1) (sha1-FB 1) (sha1-FC 1) (sha1-FD 1) (sha1-FE 1) (sha1-FT 1)
+ (sha1-FA 1) (sha1-FB 1) (sha1-FC 2) (sha1-FD 2) (sha1-FE 2) (sha1-FT 2)
+ (sha1-FA 2) (sha1-FB 2) (sha1-FC 2) (sha1-FD 2) (sha1-FE 2) (sha1-FT 2)
+ (sha1-FA 2) (sha1-FB 2) (sha1-FC 2) (sha1-FD 2) (sha1-FE 2) (sha1-FT 2)
+ (sha1-FA 2) (sha1-FB 2) (sha1-FC 2) (sha1-FD 2) (sha1-FE 3) (sha1-FT 3)
+ (sha1-FA 3) (sha1-FB 3) (sha1-FC 3) (sha1-FD 3) (sha1-FE 3) (sha1-FT 3)
+ (sha1-FA 3) (sha1-FB 3) (sha1-FC 3) (sha1-FD 3) (sha1-FE 3) (sha1-FT 3)
+ (sha1-FA 3) (sha1-FB 3) (sha1-FC 3) (sha1-FD 3) (sha1-FE 3) (sha1-FT 3)
+ (sha1-FA 4) (sha1-FB 4) (sha1-FC 4) (sha1-FD 4) (sha1-FE 4) (sha1-FT 4)
+ (sha1-FA 4) (sha1-FB 4) (sha1-FC 4) (sha1-FD 4) (sha1-FE 4) (sha1-FT 4)
+ (sha1-FA 4) (sha1-FB 4) (sha1-FC 4) (sha1-FD 4) (sha1-FE 4) (sha1-FT 4)
+ (sha1-FA 4) (sha1-FB 4)
+
+ (sha1-add (aref sha1-digest 0) E)
+ (sha1-add (aref sha1-digest 1) T)
+ (sha1-add (aref sha1-digest 2) A)
+ (sha1-add (aref sha1-digest 3) B)
+ (sha1-add (aref sha1-digest 4) C)
+ ))
+
+(defun sha1-final (&optional binary)
+ "Transform buffered sha1-data and return SHA1 message digest.
+If optional argument BINARY is non-nil, then return binary formed
+string of message digest."
+ (let ((count (logand (lsh (cdr sha1-count-lo) -3) 63)))
+ (when (< (length sha1-data) SHA1-BLOCKSIZE)
+ (setq sha1-data
+ (concat sha1-data
+ (make-string (- SHA1-BLOCKSIZE (length sha1-data)) 0))))
+ (aset sha1-data count 128)
+ (setq count (1+ count))
+ (if (> count (- SHA1-BLOCKSIZE 8))
+ (progn
+ (setq sha1-data (concat (substring sha1-data 0 count)
+ (make-string (- SHA1-BLOCKSIZE count) 0)))
+ (sha1-transform)
+ (setq sha1-data (concat (make-string (- SHA1-BLOCKSIZE 8) 0)
+ (substring sha1-data -8))))
+ (setq sha1-data (concat (substring sha1-data 0 count)
+ (make-string (- SHA1-BLOCKSIZE 8 count) 0)
+ (substring sha1-data -8))))
+ (aset sha1-data 56 (lsh (car sha1-count-hi) -8))
+ (aset sha1-data 57 (logand 255 (car sha1-count-hi)))
+ (aset sha1-data 58 (lsh (cdr sha1-count-hi) -8))
+ (aset sha1-data 59 (logand 255 (cdr sha1-count-hi)))
+ (aset sha1-data 60 (lsh (car sha1-count-lo) -8))
+ (aset sha1-data 61 (logand 255 (car sha1-count-lo)))
+ (aset sha1-data 62 (lsh (cdr sha1-count-lo) -8))
+ (aset sha1-data 63 (logand 255 (cdr sha1-count-lo)))
+ (sha1-transform)
+ (if binary
+ (mapconcat
+ (lambda (elem)
+ (concat (char-to-string (/ (car elem) 256))
+ (char-to-string (% (car elem) 256))
+ (char-to-string (/ (cdr elem) 256))
+ (char-to-string (% (cdr elem) 256))))
+ (list (aref sha1-digest 0) (aref sha1-digest 1) (aref sha1-digest 2)
+ (aref sha1-digest 3) (aref sha1-digest 4))
+ "")
+ (format "%04x%04x%04x%04x%04x%04x%04x%04x%04x%04x"
+ (car (aref sha1-digest 0)) (cdr (aref sha1-digest 0))
+ (car (aref sha1-digest 1)) (cdr (aref sha1-digest 1))
+ (car (aref sha1-digest 2)) (cdr (aref sha1-digest 2))
+ (car (aref sha1-digest 3)) (cdr (aref sha1-digest 3))
+ (car (aref sha1-digest 4)) (cdr (aref sha1-digest 4)))
+ )))
+
+(defun sha1-encode (message &optional binary)
+ "Encodes MESSAGE using the SHA1 message digest algorithm.
+MESSAGE must be a unibyte-string.
+By default, return a string which formed hex-decimal charcters
+from message digest.
+If optional argument BINARY is non-nil, then return binary formed
+string of message digest."
+ (sha1-init)
+ (sha1-update message)
+ (sha1-final binary))
+
+(defun sha1-encode-binary (message)
+ "Encodes MESSAGE using the SHA1 message digest algorithm.
+MESSAGE must be a unibyte-string.
+Return binary formed string of message digest."
+ (sha1-encode message 'binary))
+
+(provide 'sha1)
+
+;;; sha1.el ends here
projects / gnus / commitdiff