which included commits to RCS files with non-trunk default branches.
oort
pgg
smilies
+makepub-beta
in your Emacs, you should probably exit that Emacs and start a new one
to fire up Gnus.
-Gnus does absolutely not work with anything older than Emacs 20.3 or
-XEmacs 20.0. You definitely need a relatively current Emacs.
+Gnus does absolutely not work with anything older than Emacs 21.1 or
+XEmacs 21.4. You definitely need a relatively current Emacs.
To compile the Gnus manual, you either need a pretty new Emacs, or a
pretty new version of the texinfo tools.
Create the group by saying
-`G V my.virtual.newsgroup<RET>nnvirtual<RET>^rec\.aquaria\.*<RET>'
+`G m my.virtual.newsgroup<RET>nnvirtual<RET>^rec\.aquaria\.*<RET>'
This will create the group "nnvirtual:my.virtual.newsgroup", which
will collect all articles from all the groups in the "rec.aquaria"
-Makefile
-version
*.elc
+Makefile
+auto-autoloads.el
+custom-load.el
gnus-load.el
old
+version
(goto-char (point-min))
(forward-line (1- number))
(when (re-search-forward gnus-cite-attribution-suffix
- (gnus-point-at-eol)
+ (point-at-eol)
t)
(gnus-article-add-button (match-beginning 1) (match-end 1)
'gnus-cite-toggle prefix))
;; Each line.
(setq begin (point)
guess-limit (progn (skip-chars-forward "^> \t\r\n") (point))
- end (gnus-point-at-bol 2)
+ end (point-at-bol 2)
start end)
(goto-char begin)
;; Ignore standard Supercite attribution prefix.
;; Each prefix.
(setq end (match-end 0)
prefix (buffer-substring begin end))
- (gnus-set-text-properties 0 (length prefix) nil prefix)
+ (set-text-properties 0 (length prefix) nil prefix)
(setq entry (assoc prefix alist))
(if entry
(setcdr entry (cons line (cdr entry)))
(let ((al (buffer-substring (save-excursion (beginning-of-line 0)
(1+ (point)))
end)))
- (if (not (assoc al al-alist))
- (progn
- (push (list wrote in prefix tag)
- gnus-cite-loose-attribution-alist)
- (push (cons al t) al-alist))))))))
+ (when (not (assoc al al-alist))
+ (push (list wrote in prefix tag)
+ gnus-cite-loose-attribution-alist)
+ (push (cons al t) al-alist)))))))
(defun gnus-cite-connect-attributions ()
;; Connect attributions to citations
(require 'nnmail)
(defvar gnus-group-split-updated-hook nil
- "Hook called just after nnmail-split-fancy is updated by
-gnus-group-split-update.")
+ "Hook called just after `nnmail-split-fancy' is updated by
+`gnus-group-split-update'.")
(defvar gnus-group-split-default-catch-all-group "mail.misc"
"Group name (or arbitrary fancy split) with default splitting rules.
-Used by gnus-group-split and gnus-group-split-update as a fallback
+Used by `gnus-group-split' and `gnus-group-split-update' as a fallback
split, in case none of the group-based splits matches.")
;;;###autoload
(defun gnus-group-split-setup (&optional auto-update catch-all)
- "Set up the split for nnmail-split-fancy.
+ "Set up the split for `nnmail-split-fancy'.
Sets things up so that nnmail-split-fancy is used for mail
splitting, and defines the variable nnmail-split-fancy according with
group parameters.
If AUTO-UPDATE is non-nil (prefix argument accepted, if called
interactively), it makes sure nnmail-split-fancy is re-computed before
-getting new mail, by adding gnus-group-split-update to
-nnmail-pre-get-new-mail-hook.
+getting new mail, by adding `gnus-group-split-update' to
+`nnmail-pre-get-new-mail-hook'.
A non-nil CATCH-ALL replaces the current value of
-gnus-group-split-default-catch-all-group. This variable is only used
+`gnus-group-split-default-catch-all-group'. This variable is only used
by gnus-group-split-update, and only when its CATCH-ALL argument is
nil. This argument may contain any fancy split, that will be added as
-the last split in a `|' split produced by gnus-group-split-fancy,
+the last split in a `|' split produced by `gnus-group-split-fancy',
unless overridden by any group marked as a catch-all group. Typical
uses are as simple as the name of a default mail group, but more
elaborate fancy splits may also be useful to split mail that doesn't
;;;###autoload
(defun gnus-group-split-update (&optional catch-all)
- "Computes nnmail-split-fancy from group params and CATCH-ALL, by
+ "Computes `nnmail-split-fancy' from group params and CATCH-ALL, by
calling (gnus-group-split-fancy nil nil CATCH-ALL).
-If CATCH-ALL is nil, gnus-group-split-default-catch-all-group is used
-instead. This variable is set by gnus-group-split-setup."
+If CATCH-ALL is nil, `gnus-group-split-default-catch-all-group' is used
+instead. This variable is set by `gnus-group-split-setup'."
(interactive)
(setq nnmail-split-fancy
(gnus-group-split-fancy
;;;###autoload
(defun gnus-group-split ()
- "Uses information from group parameters in order to split mail.
+ "Use information from group parameters in order to split mail.
See `gnus-group-split-fancy' for more information.
-gnus-group-split is a valid value for nnmail-split-methods."
+`gnus-group-split' is a valid value for `nnmail-split-methods'."
(let (nnmail-split-fancy)
(gnus-group-split-update)
(nnmail-split-fancy)))
;;
;;; Code:
+(eval-when-compile (require 'cl))
+
(require 'gnus)
-(require 'custom)
(require 'gnus-art)
;;; User variables:
--- /dev/null
+;;; hmac-def.el --- A macro for defining HMAC functions.
+
+;; Copyright (C) 1999, 2001 Free Software Foundation, Inc.
+
+;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
+;; Keywords: HMAC, RFC 2104
+
+;; 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 RFC 2104,
+;; "HMAC: Keyed-Hashing for Message Authentication".
+
+;;; Code:
+
+(defmacro define-hmac-function (name H B L &optional bit)
+ "Define a function NAME(TEXT KEY) which computes HMAC with function H.
+
+HMAC function is H(KEY XOR opad, H(KEY XOR ipad, TEXT)):
+
+H is a cryptographic hash function, such as SHA1 and MD5, which takes
+a string and return a digest of it (in binary form).
+B is a byte-length of a block size of H. (B=64 for both SHA1 and MD5.)
+L is a byte-length of hash outputs. (L=16 for MD5, L=20 for SHA1.)
+If BIT is non-nil, truncate output to specified bits."
+ (` (defun (, name) (text key)
+ (, (concat "Compute "
+ (upcase (symbol-name name))
+ " over TEXT with KEY."))
+ (let ((key-xor-ipad (make-string (, B) ?\x36))
+ (key-xor-opad (make-string (, B) ?\x5C))
+ (len (length key))
+ (pos 0))
+ (unwind-protect
+ (progn
+ ;; if `key' is longer than the block size, apply hash function
+ ;; to `key' and use the result as a real `key'.
+ (if (> len (, B))
+ (setq key ((, H) key)
+ len (, L)))
+ (while (< pos len)
+ (aset key-xor-ipad pos (logxor (aref key pos) ?\x36))
+ (aset key-xor-opad pos (logxor (aref key pos) ?\x5C))
+ (setq pos (1+ pos)))
+ (setq key-xor-ipad (unwind-protect
+ (concat key-xor-ipad text)
+ (fillarray key-xor-ipad 0))
+ key-xor-ipad (unwind-protect
+ ((, H) key-xor-ipad)
+ (fillarray key-xor-ipad 0))
+ key-xor-opad (unwind-protect
+ (concat key-xor-opad key-xor-ipad)
+ (fillarray key-xor-opad 0))
+ key-xor-opad (unwind-protect
+ ((, H) key-xor-opad)
+ (fillarray key-xor-opad 0)))
+ ;; now `key-xor-opad' contains
+ ;; H(KEY XOR opad, H(KEY XOR ipad, TEXT)).
+ (, (if (and bit (< (/ bit 8) L))
+ (` (substring key-xor-opad 0 (, (/ bit 8))))
+ ;; return a copy of `key-xor-opad'.
+ (` (concat key-xor-opad)))))
+ ;; cleanup.
+ (fillarray key-xor-ipad 0)
+ (fillarray key-xor-opad 0))))))
+
+(provide 'hmac-def)
+
+;;; hmac-def.el ends here
--- /dev/null
+;;; hmac-md5.el --- Compute HMAC-MD5.
+
+;; Copyright (C) 1999, 2001 Free Software Foundation, Inc.
+
+;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
+;; Keywords: HMAC, RFC 2104, HMAC-MD5, MD5, KEYED-MD5, CRAM-MD5
+
+;; 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:
+
+;; Test cases from RFC 2202, "Test Cases for HMAC-MD5 and HMAC-SHA-1".
+;;
+;; (encode-hex-string (hmac-md5 "Hi There" (make-string 16 ?\x0b)))
+;; => "9294727a3638bb1c13f48ef8158bfc9d"
+;;
+;; (encode-hex-string (hmac-md5 "what do ya want for nothing?" "Jefe"))
+;; => "750c783e6ab0b503eaa86e310a5db738"
+;;
+;; (encode-hex-string (hmac-md5 (make-string 50 ?\xdd) (make-string 16 ?\xaa)))
+;; => "56be34521d144c88dbb8c733f0e8b3f6"
+;;
+;; (encode-hex-string
+;; (hmac-md5
+;; (make-string 50 ?\xcd)
+;; (decode-hex-string "0102030405060708090a0b0c0d0e0f10111213141516171819")))
+;; => "697eaf0aca3a3aea3a75164746ffaa79"
+;;
+;; (encode-hex-string
+;; (hmac-md5 "Test With Truncation" (make-string 16 ?\x0c)))
+;; => "56461ef2342edc00f9bab995690efd4c"
+;;
+;; (encode-hex-string
+;; (hmac-md5-96 "Test With Truncation" (make-string 16 ?\x0c)))
+;; => "56461ef2342edc00f9bab995"
+;;
+;; (encode-hex-string
+;; (hmac-md5
+;; "Test Using Larger Than Block-Size Key - Hash Key First"
+;; (make-string 80 ?\xaa)))
+;; => "6b1ab7fe4bd7bf8f0b62e6ce61b9d0cd"
+;;
+;; (encode-hex-string
+;; (hmac-md5
+;; "Test Using Larger Than Block-Size Key and Larger Than One Block-Size Data"
+;; (make-string 80 ?\xaa)))
+;; => "6f630fad67cda0ee1fb1f562db3aa53e"
+
+;;; Code:
+
+(eval-when-compile (require 'hmac-def))
+(require 'hex-util) ; (decode-hex-string STRING)
+(require 'md5) ; expects (md5 STRING)
+
+(defun md5-binary (string)
+ "Return the MD5 of STRING in binary form."
+ (if (condition-case nil
+ ;; `md5' of v21 takes 4th arg CODING (and 5th arg NOERROR).
+ (md5 "" nil nil 'binary) ; => "d41d8cd98f00b204e9800998ecf8427e"
+ (wrong-number-of-arguments nil))
+ (decode-hex-string (md5 string nil nil 'binary))
+ (decode-hex-string (md5 string))))
+
+(define-hmac-function hmac-md5 md5-binary 64 16) ; => (hmac-md5 TEXT KEY)
+(define-hmac-function hmac-md5-96 md5-binary 64 16 96)
+
+(provide 'hmac-md5)
+
+;;; hmac-md5.el ends here
;;; imap.el --- imap library
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003
+;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004
;; Free Software Foundation, Inc.
;; Author: Simon Josefsson <jas@pdc.kth.se>
;; explanatory for someone that know IMAP. All functions have
;; additional documentation on how to invoke them.
;;
-;; imap.el support RFC1730/2060 (IMAP4/IMAP4rev1), implemented IMAP
-;; extensions are RFC2195 (CRAM-MD5), RFC2086 (ACL), RFC2342
+;; imap.el support RFC1730/2060/RFC3501 (IMAP4/IMAP4rev1), implemented
+;; IMAP extensions are RFC2195 (CRAM-MD5), RFC2086 (ACL), RFC2342
;; (NAMESPACE), RFC2359 (UIDPLUS), the IMAP-part of RFC2595 (STARTTLS,
;; LOGINDISABLED) (with use of external library starttls.el and
-;; program starttls) and the GSSAPI / kerberos V4 sections of RFC1731
-;; (with use of external program `imtest'). It also take advantage
-;; the UNSELECT extension in Cyrus IMAPD.
+;; program starttls), and the GSSAPI / kerberos V4 sections of RFC1731
+;; (with use of external program `imtest'), RFC2971 (ID). It also
+;; take advantage the UNSELECT extension in Cyrus IMAPD.
;;
;; Without the work of John McClary Prevost and Jim Radford this library
;; would not have seen the light of day. Many thanks.
(eval-when-compile (require 'cl))
(eval-and-compile
- (autoload 'base64-decode-string "base64")
- (autoload 'base64-encode-string "base64")
(autoload 'starttls-open-stream "starttls")
(autoload 'starttls-negotiate "starttls")
(autoload 'digest-md5-parse-digest-challenge "digest-md5")
(autoload 'digest-md5-digest-uri "digest-md5")
(autoload 'digest-md5-challenge "digest-md5")
(autoload 'rfc2104-hash "rfc2104")
- (autoload 'md5 "md5")
(autoload 'utf7-encode "utf7")
(autoload 'utf7-decode "utf7")
(autoload 'format-spec "format-spec")
(autoload 'format-spec-make "format-spec")
- (autoload 'open-tls-stream "tls")
- ;; Avoid use gnus-point-at-eol so we're independent of Gnus. These
- ;; days we have point-at-eol anyhow.
- (if (fboundp 'point-at-eol)
- (defalias 'imap-point-at-eol 'point-at-eol)
- (defun imap-point-at-eol ()
- (save-excursion
- (end-of-line)
- (point)))))
+ (autoload 'open-tls-stream "tls"))
;; User variables.
:type 'number
:group 'imap)
+(defcustom imap-store-password nil
+ "If non-nil, store session password without promting."
+ :group 'imap
+ :type 'boolean)
+
;; Various variables.
(defvar imap-fetch-data-hook nil
imap-current-target-mailbox
imap-message-data
imap-capability
+ imap-id
imap-namespace
imap-state
imap-reached-tag
(defvar imap-capability nil
"Capability for server.")
+(defvar imap-id nil
+ "Identity of server.
+See RFC 2971.")
+
(defvar imap-namespace nil
"Namespace for current server.")
(progn
(setq ret t
imap-username user)
- (if (and (not imap-password)
- (y-or-n-p "Store password for this session? "))
- (setq imap-password passwd)))
+ (when (and (not imap-password)
+ (or imap-store-password
+ (y-or-n-p "Store password for this session? ")))
+ (setq imap-password passwd)))
(message "Login failed...")
(setq passwd nil)
(setq imap-password nil)
(memq (intern (upcase (symbol-name identifier))) imap-capability)
imap-capability)))
+(defun imap-id (&optional list-of-values buffer)
+ "Identify client to server in BUFFER, and return server identity.
+LIST-OF-VALUES is nil, or a plist with identifier and value
+strings to send to the server to identify the client.
+
+Return a list of identifiers which server in BUFFER support, or
+nil if it doesn't support ID or returns no information.
+
+If BUFFER is nil, the current buffer is assumed."
+ (with-current-buffer (or buffer (current-buffer))
+ (when (and (imap-capability 'ID)
+ (imap-ok-p (imap-send-command-wait
+ (if (null list-of-values)
+ "ID NIL"
+ (concat "ID (" (mapconcat (lambda (el)
+ (concat "\"" el "\""))
+ list-of-values
+ " ") ")")))))
+ imap-id)))
+
(defun imap-namespace (&optional buffer)
"Return a namespace hierarchy at server in BUFFER.
If BUFFER is nil, the current buffer is assumed."
(read (concat "(" (upcase (buffer-substring
(point) (point-max)))
")"))))
+ (ID (setq imap-id (read (buffer-substring (point)
+ (point-max)))))
(ACL (imap-parse-acl))
(t (case (prog1 (read (current-buffer))
(imap-forward))
(defun imap-parse-flag-list ()
(let (flag-list start)
- (assert (eq (char-after) ?\() t "In imap-parse-flag-list")
+ (assert (eq (char-after) ?\() nil "In imap-parse-flag-list")
(while (and (not (eq (char-after) ?\)))
(setq start (progn
(imap-forward)
;; next line for Courier IMAP bug.
(skip-chars-forward " ")
(point)))
- (> (skip-chars-forward "^ )" (imap-point-at-eol)) 0))
+ (> (skip-chars-forward "^ )" (point-at-eol)) 0))
(push (buffer-substring start (point)) flag-list))
- (assert (eq (char-after) ?\)) t "In imap-parse-flag-list")
+ (assert (eq (char-after) ?\)) nil "In imap-parse-flag-list")
(imap-forward)
(nreverse flag-list)))
(while (eq (char-after) ?\ )
(imap-forward)
(push (imap-parse-body-extension) b-e))
- (assert (eq (char-after) ?\)) t "In imap-parse-body-extension")
+ (assert (eq (char-after) ?\)) nil "In imap-parse-body-extension")
(imap-forward)
(nreverse b-e))
(or (imap-parse-number)
(push (and (imap-parse-nil) nil) body))
(setq body
(append (imap-parse-body-ext) body))) ;; body-ext-...
- (assert (eq (char-after) ?\)) t "In imap-parse-body")
+ (assert (eq (char-after) ?\)) nil "In imap-parse-body")
(imap-forward)
(nreverse body))
(push (imap-parse-nstring) body) ;; body-fld-md5
(setq body (append (imap-parse-body-ext) body))) ;; body-ext-1part..
- (assert (eq (char-after) ?\)) t "In imap-parse-body 2")
+ (assert (eq (char-after) ?\)) nil "In imap-parse-body 2")
(imap-forward)
(nreverse body)))))
(eval-and-compile
(autoload 'pop3-movemail "pop3")
(autoload 'pop3-get-message-count "pop3")
- (autoload 'nnheader-cancel-timer "nnheader")
- (autoload 'nnheader-run-at-time "nnheader"))
+ (autoload 'nnheader-cancel-timer "nnheader"))
(require 'format-spec)
(require 'mm-util)
(require 'message) ;; for `message-directory'
"Open and close a POP connection shortly.
POP server should be defined in `mail-source-primary-source' (which is
preferred) or `mail-sources'. You may use it for the POP-before-SMTP
-authentication. To do that, you need to set the option
-`message-send-mail-function' to `message-smtpmail-send-it' and put the
-following line in .gnus file:
+authentication. To do that, you need to set the
+`message-send-mail-function' variable as `message-smtpmail-send-it'
+and put the following line in your ~/.gnus.el file:
\(add-hook 'message-send-mail-hook 'mail-source-touch-pop)
-"
+
+See the Gnus manual for details."
(let ((sources (if mail-source-primary-source
(list mail-source-primary-source)
mail-sources)))
(setq display-time-mail-function #'mail-source-new-mail-p)
;; Set up the main timer.
(setq mail-source-report-new-mail-timer
- (nnheader-run-at-time
+ (run-at-time
(* 60 mail-source-report-new-mail-interval)
(* 60 mail-source-report-new-mail-interval)
#'mail-source-start-idle-timer))
--- /dev/null
+;;; md4.el --- MD4 Message Digest Algorithm.
+
+;; Copyright (C) 2004 Free Software Foundation, Inc.
+;; Copyright (C) 2001 Taro Kawagishi
+;; Author: Taro Kawagishi <tarok@transpulse.org>
+;; Keywords: MD4
+;; Version: 1.00
+;; Created: February 2001
+
+;; 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.
+
+;;; Code:
+
+;;;
+;;; MD4 hash calculation
+
+(defvar md4-buffer (make-vector 4 '(0 . 0))
+ "work buffer of four 32-bit integers")
+
+(defun md4 (in n)
+ "Returns the MD4 hash string of 16 bytes long for a string IN of N
+bytes long. N is required to handle strings containing character 0."
+ (let (m
+ (b (cons 0 (* n 8)))
+ (i 0)
+ (buf (make-string 128 0)) c4)
+ ;; initial values
+ (aset md4-buffer 0 '(26437 . 8961)) ;0x67452301
+ (aset md4-buffer 1 '(61389 . 43913)) ;0xefcdab89
+ (aset md4-buffer 2 '(39098 . 56574)) ;0x98badcfe
+ (aset md4-buffer 3 '(4146 . 21622)) ;0x10325476
+
+ ;; process the string in 64 bits chunks
+ (while (> n 64)
+ (setq m (md4-copy64 (substring in 0 64)))
+ (md4-64 m)
+ (setq in (substring in 64))
+ (setq n (- n 64)))
+
+ ;; process the rest of the string (length is now n <= 64)
+ (setq i 0)
+ (while (< i n)
+ (aset buf i (aref in i))
+ (setq i (1+ i)))
+ (aset buf n 128) ;0x80
+ (if (<= n 55)
+ (progn
+ (setq c4 (md4-pack-int32 b))
+ (aset buf 56 (aref c4 0))
+ (aset buf 57 (aref c4 1))
+ (aset buf 58 (aref c4 2))
+ (aset buf 59 (aref c4 3))
+ (setq m (md4-copy64 buf))
+ (md4-64 m))
+ ;; else
+ (setq c4 (md4-pack-int32 b))
+ (aset buf 120 (aref c4 0))
+ (aset buf 121 (aref c4 1))
+ (aset buf 122 (aref c4 2))
+ (aset buf 123 (aref c4 3))
+ (setq m (md4-copy64 buf))
+ (md4-64 m)
+ (setq m (md4-copy64 (substring buf 64)))
+ (md4-64 m)))
+
+ (concat (md4-pack-int32 (aref md4-buffer 0))
+ (md4-pack-int32 (aref md4-buffer 1))
+ (md4-pack-int32 (aref md4-buffer 2))
+ (md4-pack-int32 (aref md4-buffer 3))))
+
+(defsubst md4-F (x y z) (logior (logand x y) (logand (lognot x) z)))
+(defsubst md4-G (x y z) (logior (logand x y) (logand x z) (logand y z)))
+(defsubst md4-H (x y z) (logxor x y z))
+
+(defmacro md4-make-step (name func)
+ (`
+ (defun (, name) (a b c d xk s ac)
+ (let*
+ ((h1 (+ (car a) ((, func) (car b) (car c) (car d)) (car xk) (car ac)))
+ (l1 (+ (cdr a) ((, func) (cdr b) (cdr c) (cdr d)) (cdr xk) (cdr ac)))
+ (h2 (logand 65535 (+ h1 (lsh l1 -16))))
+ (l2 (logand 65535 l1))
+ ;; cyclic shift of 32 bits integer
+ (h3 (logand 65535 (if (> s 15)
+ (+ (lsh h2 (- s 32)) (lsh l2 (- s 16)))
+ (+ (lsh h2 s) (lsh l2 (- s 16))))))
+ (l3 (logand 65535 (if (> s 15)
+ (+ (lsh l2 (- s 32)) (lsh h2 (- s 16)))
+ (+ (lsh l2 s) (lsh h2 (- s 16)))))))
+ (cons h3 l3)))))
+
+(md4-make-step md4-round1 md4-F)
+(md4-make-step md4-round2 md4-G)
+(md4-make-step md4-round3 md4-H)
+
+(defsubst md4-add (x y)
+ "Return 32-bit sum of 32-bit integers X and Y."
+ (let ((h (+ (car x) (car y)))
+ (l (+ (cdr x) (cdr y))))
+ (cons (logand 65535 (+ h (lsh l -16))) (logand 65535 l))))
+
+(defsubst md4-and (x y)
+ (cons (logand (car x) (car y)) (logand (cdr x) (cdr y))))
+
+(defun md4-64 (m)
+ "Calculate md4 of 64 bytes chunk M which is represented as 16 pairs of
+32 bits integers. The resulting md4 value is placed in md4-buffer."
+ (let ((a (aref md4-buffer 0))
+ (b (aref md4-buffer 1))
+ (c (aref md4-buffer 2))
+ (d (aref md4-buffer 3)))
+ (setq a (md4-round1 a b c d (aref m 0) 3 '(0 . 0))
+ d (md4-round1 d a b c (aref m 1) 7 '(0 . 0))
+ c (md4-round1 c d a b (aref m 2) 11 '(0 . 0))
+ b (md4-round1 b c d a (aref m 3) 19 '(0 . 0))
+ a (md4-round1 a b c d (aref m 4) 3 '(0 . 0))
+ d (md4-round1 d a b c (aref m 5) 7 '(0 . 0))
+ c (md4-round1 c d a b (aref m 6) 11 '(0 . 0))
+ b (md4-round1 b c d a (aref m 7) 19 '(0 . 0))
+ a (md4-round1 a b c d (aref m 8) 3 '(0 . 0))
+ d (md4-round1 d a b c (aref m 9) 7 '(0 . 0))
+ c (md4-round1 c d a b (aref m 10) 11 '(0 . 0))
+ b (md4-round1 b c d a (aref m 11) 19 '(0 . 0))
+ a (md4-round1 a b c d (aref m 12) 3 '(0 . 0))
+ d (md4-round1 d a b c (aref m 13) 7 '(0 . 0))
+ c (md4-round1 c d a b (aref m 14) 11 '(0 . 0))
+ b (md4-round1 b c d a (aref m 15) 19 '(0 . 0))
+
+ a (md4-round2 a b c d (aref m 0) 3 '(23170 . 31129)) ;0x5A827999
+ d (md4-round2 d a b c (aref m 4) 5 '(23170 . 31129))
+ c (md4-round2 c d a b (aref m 8) 9 '(23170 . 31129))
+ b (md4-round2 b c d a (aref m 12) 13 '(23170 . 31129))
+ a (md4-round2 a b c d (aref m 1) 3 '(23170 . 31129))
+ d (md4-round2 d a b c (aref m 5) 5 '(23170 . 31129))
+ c (md4-round2 c d a b (aref m 9) 9 '(23170 . 31129))
+ b (md4-round2 b c d a (aref m 13) 13 '(23170 . 31129))
+ a (md4-round2 a b c d (aref m 2) 3 '(23170 . 31129))
+ d (md4-round2 d a b c (aref m 6) 5 '(23170 . 31129))
+ c (md4-round2 c d a b (aref m 10) 9 '(23170 . 31129))
+ b (md4-round2 b c d a (aref m 14) 13 '(23170 . 31129))
+ a (md4-round2 a b c d (aref m 3) 3 '(23170 . 31129))
+ d (md4-round2 d a b c (aref m 7) 5 '(23170 . 31129))
+ c (md4-round2 c d a b (aref m 11) 9 '(23170 . 31129))
+ b (md4-round2 b c d a (aref m 15) 13 '(23170 . 31129))
+
+ a (md4-round3 a b c d (aref m 0) 3 '(28377 . 60321)) ;0x6ED9EBA1
+ d (md4-round3 d a b c (aref m 8) 9 '(28377 . 60321))
+ c (md4-round3 c d a b (aref m 4) 11 '(28377 . 60321))
+ b (md4-round3 b c d a (aref m 12) 15 '(28377 . 60321))
+ a (md4-round3 a b c d (aref m 2) 3 '(28377 . 60321))
+ d (md4-round3 d a b c (aref m 10) 9 '(28377 . 60321))
+ c (md4-round3 c d a b (aref m 6) 11 '(28377 . 60321))
+ b (md4-round3 b c d a (aref m 14) 15 '(28377 . 60321))
+ a (md4-round3 a b c d (aref m 1) 3 '(28377 . 60321))
+ d (md4-round3 d a b c (aref m 9) 9 '(28377 . 60321))
+ c (md4-round3 c d a b (aref m 5) 11 '(28377 . 60321))
+ b (md4-round3 b c d a (aref m 13) 15 '(28377 . 60321))
+ a (md4-round3 a b c d (aref m 3) 3 '(28377 . 60321))
+ d (md4-round3 d a b c (aref m 11) 9 '(28377 . 60321))
+ c (md4-round3 c d a b (aref m 7) 11 '(28377 . 60321))
+ b (md4-round3 b c d a (aref m 15) 15 '(28377 . 60321)))
+
+ (aset md4-buffer 0 (md4-add a (aref md4-buffer 0)))
+ (aset md4-buffer 1 (md4-add b (aref md4-buffer 1)))
+ (aset md4-buffer 2 (md4-add c (aref md4-buffer 2)))
+ (aset md4-buffer 3 (md4-add d (aref md4-buffer 3)))
+ ))
+
+(defun md4-copy64 (seq)
+ "Unpack a 64 bytes string into 16 pairs of 32 bits integers."
+ (let ((int32s (make-vector 16 0)) (i 0) j)
+ (while (< i 16)
+ (setq j (* i 4))
+ (aset int32s i (cons (+ (aref seq (+ j 2)) (lsh (aref seq (+ j 3)) 8))
+ (+ (aref seq j) (lsh (aref seq (1+ j)) 8))))
+ (setq i (1+ i)))
+ int32s))
+
+;;;
+;;; sub functions
+
+(defun md4-pack-int16 (int16)
+ "Pack 16 bits integer in 2 bytes string as little endian."
+ (let ((str (make-string 2 0)))
+ (aset str 0 (logand int16 255))
+ (aset str 1 (lsh int16 -8))
+ str))
+
+(defun md4-pack-int32 (int32)
+ "Pack 32 bits integer in a 4 bytes string as little endian. A 32 bits
+integer is represented as a pair of two 16 bits integers (cons high low)."
+ (let ((str (make-string 4 0))
+ (h (car int32)) (l (cdr int32)))
+ (aset str 0 (logand l 255))
+ (aset str 1 (lsh l -8))
+ (aset str 2 (logand h 255))
+ (aset str 3 (lsh h -8))
+ str))
+
+(defun md4-unpack-int16 (str)
+ (if (eq 2 (length str))
+ (+ (lsh (aref str 1) 8) (aref str 0))
+ (error "%s is not 2 bytes long" str)))
+
+(defun md4-unpack-int32 (str)
+ (if (eq 4 (length str))
+ (cons (+ (lsh (aref str 3) 8) (aref str 2))
+ (+ (lsh (aref str 1) 8) (aref str 0)))
+ (error "%s is not 4 bytes long" str)))
+
+(provide 'md4)
+
+;;; md4.el ends here
If this is 'imap-mailbox-lsub, then use a server-side subscription list to
restrict visible folders.")
+(defcustom nnimap-id nil
+ "Plist with client identity to send to server upon login.
+Nil means no information is sent, symbol `no' to disable ID query
+alltogheter, or plist with identifier-value pairs to send to
+server. RFC 2971 describes the list as follows:
+
+ Any string may be sent as a field, but the following are defined to
+ describe certain values that might be sent. Implementations are free
+ to send none, any, or all of these. Strings are not case-sensitive.
+ Field strings MUST NOT be longer than 30 octets. Value strings MUST
+ NOT be longer than 1024 octets. Implementations MUST NOT send more
+ than 30 field-value pairs.
+
+ name Name of the program
+ version Version number of the program
+ os Name of the operating system
+ os-version Version of the operating system
+ vendor Vendor of the client/server
+ support-url URL to contact for support
+ address Postal address of contact/vendor
+ date Date program was released, specified as a date-time
+ in IMAP4rev1
+ command Command used to start the program
+ arguments Arguments supplied on the command line, if any
+ if any
+ environment Description of environment, i.e., UNIX environment
+ variables or Windows registry settings
+
+ Implementations MUST NOT send the same field name more than once.
+
+An example plist would be '(\"name\" \"Gnus\" \"version\" gnus-version-number
+\"os\" system-configuration \"vendor\" \"GNU\")."
+ :group 'nnimap
+ :type '(choice (const :tag "No information" nil)
+ (const :tag "Disable ID query" no)
+ (plist :key-type string :value-type string)))
+
(defcustom nnimap-debug nil
"If non-nil, random debug spews are placed in *nnimap-debug* buffer."
:group 'nnimap
(prog1
(push (list server nnimap-server-buffer)
nnimap-server-buffer-alist)
+ (imap-id nnimap-id nnimap-server-buffer)
(nnimap-possibly-change-server server))
(imap-close nnimap-server-buffer)
(kill-buffer nnimap-server-buffer)
All buffers that have been created by that
backend should be killed. (Not the nntp-server-buffer, though.) This
function is generally only called when Gnus is shutting down."
- (mapcar (lambda (server) (nnimap-close-server (car server)))
- nnimap-server-buffer-alist)
+ (mapc (lambda (server) (nnimap-close-server (car server)))
+ nnimap-server-buffer-alist)
(setq nnimap-server-buffer-alist nil))
(deffoo nnimap-status-message (&optional server)
(if (memq 'dormant cmdmarks)
(setq cmdmarks (cons 'tick cmdmarks))))
;; remove stuff we are forbidden to store
- (mapcar (lambda (mark)
- (if (imap-message-flag-permanent-p
- (nnimap-mark-to-flag mark))
- (setq marks (cons mark marks))))
- cmdmarks)
+ (mapc (lambda (mark)
+ (if (imap-message-flag-permanent-p
+ (nnimap-mark-to-flag mark))
+ (setq marks (cons mark marks))))
+ cmdmarks)
(when (and range marks)
(cond ((eq what 'del)
(imap-message-flags-del
(error "Your server does not support ACL editing"))
(with-current-buffer nnimap-server-buffer
;; delete all removed identifiers
- (mapcar (lambda (old-acl)
- (unless (assoc (car old-acl) new-acls)
- (or (imap-mailbox-acl-delete (car old-acl) mailbox)
- (error "Can't delete ACL for %s" (car old-acl)))))
- old-acls)
+ (mapc (lambda (old-acl)
+ (unless (assoc (car old-acl) new-acls)
+ (or (imap-mailbox-acl-delete (car old-acl) mailbox)
+ (error "Can't delete ACL for %s" (car old-acl)))))
+ old-acls)
;; set all changed acl's
- (mapcar (lambda (new-acl)
- (let ((new-rights (cdr new-acl))
- (old-rights (cdr (assoc (car new-acl) old-acls))))
- (unless (and old-rights new-rights
- (string= old-rights new-rights))
- (or (imap-mailbox-acl-set (car new-acl) new-rights mailbox)
- (error "Can't set ACL for %s to %s" (car new-acl)
- new-rights)))))
- new-acls)
+ (mapc (lambda (new-acl)
+ (let ((new-rights (cdr new-acl))
+ (old-rights (cdr (assoc (car new-acl) old-acls))))
+ (unless (and old-rights new-rights
+ (string= old-rights new-rights))
+ (or (imap-mailbox-acl-set (car new-acl) new-rights mailbox)
+ (error "Can't set ACL for %s to %s" (car new-acl)
+ new-rights)))))
+ new-acls)
t)))
\f
--- /dev/null
+;;; ntlm.el --- NTLM (NT LanManager) authentication support
+
+;; Copyright (C) 2001 Taro Kawagishi
+;; Author: Taro Kawagishi <tarok@transpulse.org>
+;; Keywords: NTLM, SASL
+;; Version: 1.00
+;; Created: February 2001
+
+;; 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 library is a direct translation of the Samba release 2.2.0
+;; implementation of Windows NT and LanManager compatible password
+;; encryption.
+;;
+;; Interface functions:
+;;
+;; ntlm-build-auth-request
+;; This will return a binary string, which should be used in the
+;; base64 encoded form and it is the caller's responsibility to encode
+;; the returned string with base64.
+;;
+;; ntlm-build-auth-response
+;; It is the caller's responsibility to pass a base64 decoded string
+;; (which will be a binary string) as the first argument and to
+;; encode the returned string with base64. The second argument user
+;; should be given in user@domain format.
+;;
+;; ntlm-get-password-hashes
+;;
+;;
+;; NTLM authentication procedure example:
+;;
+;; 1. Open a network connection to the Exchange server at the IMAP port (143)
+;; 2. Receive an opening message such as:
+;; "* OK Microsoft Exchange IMAP4rev1 server version 5.5.2653.7 (XXXX) ready"
+;; 3. Ask for IMAP server capability by sending "NNN capability"
+;; 4. Receive a capability message such as:
+;; "* CAPABILITY IMAP4 IMAP4rev1 IDLE LITERAL+ LOGIN-REFERRALS MAILBOX-REFERRALS NAMESPACE AUTH=NTLM"
+;; 5. Ask for NTLM authentication by sending a string
+;; "NNN authenticate ntlm"
+;; 6. Receive continuation acknowledgment "+"
+;; 7. Send NTLM authentication request generated by 'ntlm-build-auth-request
+;; 8. Receive NTLM challenge string following acknowledgment "+"
+;; 9. Generate response to challenge by 'ntlm-build-auth-response
+;; (here two hash function values of the user password are encrypted)
+;; 10. Receive authentication completion message such as
+;; "NNN OK AUTHENTICATE NTLM completed."
+
+;;; Code:
+
+(require 'md4)
+
+;;;
+;;; NTLM authentication interface functions
+
+(defun ntlm-build-auth-request (user &optional domain)
+ "Return the NTLM authentication request string for USER and DOMAIN.
+USER is a string representing a user name to be authenticated and
+DOMAIN is a NT domain. USER can include a NT domain part as in
+user@domain where the string after @ is used as the domain if DOMAIN
+is not given."
+ (interactive)
+ (let ((request-ident (concat "NTLMSSP" (make-string 1 0)))
+ (request-msgType (concat (make-string 1 1) (make-string 3 0)))
+ ;0x01 0x00 0x00 0x00
+ (request-flags (concat (make-string 1 7) (make-string 1 178)
+ (make-string 2 0)))
+ ;0x07 0xb2 0x00 0x00
+ lu ld off-d off-u)
+ (when (string-match "@" user)
+ (unless domain
+ (setq domain (substring user (1+ (match-beginning 0)))))
+ (setq user (substring user 0 (match-beginning 0))))
+ ;; set fields offsets within the request struct
+ (setq lu (length user))
+ (setq ld (length domain))
+ (setq off-u 32) ;offset to the string 'user
+ (setq off-d (+ 32 lu)) ;offset to the string 'domain
+ ;; pack the request struct in a string
+ (concat request-ident ;8 bytes
+ request-msgType ;4 bytes
+ request-flags ;4 bytes
+ (md4-pack-int16 lu) ;user field, count field
+ (md4-pack-int16 lu) ;user field, max count field
+ (md4-pack-int32 (cons 0 off-u)) ;user field, offset field
+ (md4-pack-int16 ld) ;domain field, count field
+ (md4-pack-int16 ld) ;domain field, max count field
+ (md4-pack-int32 (cons 0 off-d)) ;domain field, offset field
+ user ;bufer field
+ domain ;bufer field
+ )))
+
+(eval-when-compile
+ (defmacro ntlm-string-as-unibyte (string)
+ (if (fboundp 'string-as-unibyte)
+ `(string-as-unibyte ,string)
+ string)))
+
+(defun ntlm-build-auth-response (challenge user password-hashes)
+ "Return the response string to a challenge string CHALLENGE given by
+the NTLM based server for the user USER and the password hash list
+PASSWORD-HASHES. NTLM uses two hash values which are represented
+by PASSWORD-HASHES. PASSWORD-HASHES should be a return value of
+ (list (ntlm-smb-passwd-hash password) (ntlm-md4hash password))"
+ (let* ((rchallenge (ntlm-string-as-unibyte challenge))
+ ;; get fields within challenge struct
+ ;;(ident (substring rchallenge 0 8)) ;ident, 8 bytes
+ ;;(msgType (substring rchallenge 8 12)) ;msgType, 4 bytes
+ (uDomain (substring rchallenge 12 20)) ;uDomain, 8 bytes
+ (flags (substring rchallenge 20 24)) ;flags, 4 bytes
+ (challengeData (substring rchallenge 24 32)) ;challengeData, 8 bytes
+ uDomain-len uDomain-offs
+ ;; response struct and its fields
+ lmRespData ;lmRespData, 24 bytes
+ ntRespData ;ntRespData, 24 bytes
+ domain ;ascii domain string
+ lu ld off-lm off-nt off-d off-u off-w off-s)
+ ;; extract domain string from challenge string
+ (setq uDomain-len (md4-unpack-int16 (substring uDomain 0 2)))
+ (setq uDomain-offs (md4-unpack-int32 (substring uDomain 4 8)))
+ (setq domain
+ (ntlm-unicode2ascii (substring challenge
+ (cdr uDomain-offs)
+ (+ (cdr uDomain-offs) uDomain-len))
+ (/ uDomain-len 2)))
+ ;; overwrite domain in case user is given in <user>@<domain> format
+ (when (string-match "@" user)
+ (setq domain (substring user (1+ (match-beginning 0))))
+ (setq user (substring user 0 (match-beginning 0))))
+
+ ;; generate response data
+ (setq lmRespData
+ (ntlm-smb-owf-encrypt (car password-hashes) challengeData))
+ (setq ntRespData
+ (ntlm-smb-owf-encrypt (cadr password-hashes) challengeData))
+
+ ;; get offsets to fields to pack the response struct in a string
+ (setq lu (length user))
+ (setq ld (length domain))
+ (setq off-lm 64) ;offset to string 'lmResponse
+ (setq off-nt (+ 64 24)) ;offset to string 'ntResponse
+ (setq off-d (+ 64 48)) ;offset to string 'uDomain
+ (setq off-u (+ 64 48 (* 2 ld))) ;offset to string 'uUser
+ (setq off-w (+ 64 48 (* 2 (+ ld lu)))) ;offset to string 'uWks
+ (setq off-s (+ 64 48 (* 2 (+ ld lu lu)))) ;offset to string 'sessionKey
+ ;; pack the response struct in a string
+ (concat "NTLMSSP\0" ;response ident field, 8 bytes
+ (md4-pack-int32 '(0 . 3)) ;response msgType field, 4 bytes
+
+ ;; lmResponse field, 8 bytes
+ ;;AddBytes(response,lmResponse,lmRespData,24);
+ (md4-pack-int16 24) ;len field
+ (md4-pack-int16 24) ;maxlen field
+ (md4-pack-int32 (cons 0 off-lm)) ;field offset
+
+ ;; ntResponse field, 8 bytes
+ ;;AddBytes(response,ntResponse,ntRespData,24);
+ (md4-pack-int16 24) ;len field
+ (md4-pack-int16 24) ;maxlen field
+ (md4-pack-int32 (cons 0 off-nt)) ;field offset
+
+ ;; uDomain field, 8 bytes
+ ;;AddUnicodeString(response,uDomain,domain);
+ ;;AddBytes(response, uDomain, udomain, 2*ld);
+ (md4-pack-int16 (* 2 ld)) ;len field
+ (md4-pack-int16 (* 2 ld)) ;maxlen field
+ (md4-pack-int32 (cons 0 off-d)) ;field offset
+
+ ;; uUser field, 8 bytes
+ ;;AddUnicodeString(response,uUser,u);
+ ;;AddBytes(response, uUser, uuser, 2*lu);
+ (md4-pack-int16 (* 2 lu)) ;len field
+ (md4-pack-int16 (* 2 lu)) ;maxlen field
+ (md4-pack-int32 (cons 0 off-u)) ;field offset
+
+ ;; uWks field, 8 bytes
+ ;;AddUnicodeString(response,uWks,u);
+ (md4-pack-int16 (* 2 lu)) ;len field
+ (md4-pack-int16 (* 2 lu)) ;maxlen field
+ (md4-pack-int32 (cons 0 off-w)) ;field offset
+
+ ;; sessionKey field, 8 bytes
+ ;;AddString(response,sessionKey,NULL);
+ (md4-pack-int16 0) ;len field
+ (md4-pack-int16 0) ;maxlen field
+ (md4-pack-int32 (cons 0 (- off-s off-lm))) ;field offset
+
+ ;; flags field, 4 bytes
+ flags ;
+
+ ;; buffer field
+ lmRespData ;lmResponse, 24 bytes
+ ntRespData ;ntResponse, 24 bytes
+ (ntlm-ascii2unicode domain ;unicode domain string, 2*ld bytes
+ (length domain)) ;
+ (ntlm-ascii2unicode user ;unicode user string, 2*lu bytes
+ (length user)) ;
+ (ntlm-ascii2unicode user ;unicode user string, 2*lu bytes
+ (length user)) ;
+ )))
+
+(defun ntlm-get-password-hashes (password)
+ "Return a pair of SMB hash and NT MD4 hash of the given password PASSWORD"
+ (list (ntlm-smb-passwd-hash password)
+ (ntlm-md4hash password)))
+
+(defun ntlm-ascii2unicode (str len)
+ "Convert an ASCII string into a NT Unicode string, which is
+little-endian utf16."
+ (let ((utf (make-string (* 2 len) 0)) (i 0) val)
+ (while (and (< i len)
+ (not (zerop (setq val (aref str i)))))
+ (aset utf (* 2 i) val)
+ (aset utf (1+ (* 2 i)) 0)
+ (setq i (1+ i)))
+ utf))
+
+(defun ntlm-unicode2ascii (str len)
+ "Extract 7 bits ASCII part of a little endian utf16 string STR of length LEN."
+ (let ((buf (make-string len 0)) (i 0) (j 0))
+ (while (< i len)
+ (aset buf i (logand (aref str j) 127)) ;(string-to-number "7f" 16)
+ (setq i (1+ i)
+ j (+ 2 j)))
+ buf))
+
+(defun ntlm-smb-passwd-hash (passwd)
+ "Return the SMB password hash string of 16 bytes long for the given password
+string PASSWD. PASSWD is truncated to 14 bytes if longer."
+ (let ((len (min (length passwd) 14)))
+ (ntlm-smb-des-e-p16
+ (concat (substring (upcase passwd) 0 len) ;fill top 14 bytes with passwd
+ (make-string (- 15 len) 0)))))
+
+(defun ntlm-smb-owf-encrypt (passwd c8)
+ "Return the response string of 24 bytes long for the given password
+string PASSWD based on the DES encryption. PASSWD is of at most 14
+bytes long and the challenge string C8 of 8 bytes long."
+ (let ((len (min (length passwd) 16)) p22)
+ (setq p22 (concat (substring passwd 0 len) ;fill top 16 bytes with passwd
+ (make-string (- 22 len) 0)))
+ (ntlm-smb-des-e-p24 p22 c8)))
+
+(defun ntlm-smb-des-e-p24 (p22 c8)
+ "Return a 24 bytes hashed string for a 21 bytes string P22 and a 8 bytes
+string C8."
+ (concat (ntlm-smb-hash c8 p22 t) ;hash first 8 bytes of p22
+ (ntlm-smb-hash c8 (substring p22 7) t)
+ (ntlm-smb-hash c8 (substring p22 14) t)))
+
+(defconst ntlm-smb-sp8 [75 71 83 33 64 35 36 37])
+
+(defun ntlm-smb-des-e-p16 (p15)
+ "Return a 16 bytes hashed string for a 15 bytes string P15."
+ (concat (ntlm-smb-hash ntlm-smb-sp8 p15 t) ;hash of first 8 bytes of p15
+ (ntlm-smb-hash ntlm-smb-sp8 ;hash of last 8 bytes of p15
+ (substring p15 7) t)))
+
+(defun ntlm-smb-hash (in key forw)
+ "Return the hash string of length 8 for a string IN of length 8 and
+a string KEY of length 8. FORW is t or nil."
+ (let ((out (make-string 8 0))
+ outb ;string of length 64
+ (inb (make-string 64 0))
+ (keyb (make-string 64 0))
+ (key2 (ntlm-smb-str-to-key key))
+ (i 0) aa)
+ (while (< i 64)
+ (unless (zerop (logand (aref in (/ i 8)) (lsh 1 (- 7 (% i 8)))))
+ (aset inb i 1))
+ (unless (zerop (logand (aref key2 (/ i 8)) (lsh 1 (- 7 (% i 8)))))
+ (aset keyb i 1))
+ (setq i (1+ i)))
+ (setq outb (ntlm-smb-dohash inb keyb forw))
+ (setq i 0)
+ (while (< i 64)
+ (unless (zerop (aref outb i))
+ (setq aa (aref out (/ i 8)))
+ (aset out (/ i 8)
+ (logior aa (lsh 1 (- 7 (% i 8))))))
+ (setq i (1+ i)))
+ out))
+
+(defun ntlm-smb-str-to-key (str)
+ "Return a string of length 8 for the given string STR of length 7."
+ (let ((key (make-string 8 0))
+ (i 7))
+ (aset key 0 (lsh (aref str 0) -1))
+ (aset key 1 (logior
+ (lsh (logand (aref str 0) 1) 6)
+ (lsh (aref str 1) -2)))
+ (aset key 2 (logior
+ (lsh (logand (aref str 1) 3) 5)
+ (lsh (aref str 2) -3)))
+ (aset key 3 (logior
+ (lsh (logand (aref str 2) 7) 4)
+ (lsh (aref str 3) -4)))
+ (aset key 4 (logior
+ (lsh (logand (aref str 3) 15) 3)
+ (lsh (aref str 4) -5)))
+ (aset key 5 (logior
+ (lsh (logand (aref str 4) 31) 2)
+ (lsh (aref str 5) -6)))
+ (aset key 6 (logior
+ (lsh (logand (aref str 5) 63) 1)
+ (lsh (aref str 6) -7)))
+ (aset key 7 (logand (aref str 6) 127))
+ (while (>= i 0)
+ (aset key i (lsh (aref key i) 1))
+ (setq i (1- i)))
+ key))
+
+(defconst ntlm-smb-perm1 [57 49 41 33 25 17 9
+ 1 58 50 42 34 26 18
+ 10 2 59 51 43 35 27
+ 19 11 3 60 52 44 36
+ 63 55 47 39 31 23 15
+ 7 62 54 46 38 30 22
+ 14 6 61 53 45 37 29
+ 21 13 5 28 20 12 4])
+
+(defconst ntlm-smb-perm2 [14 17 11 24 1 5
+ 3 28 15 6 21 10
+ 23 19 12 4 26 8
+ 16 7 27 20 13 2
+ 41 52 31 37 47 55
+ 30 40 51 45 33 48
+ 44 49 39 56 34 53
+ 46 42 50 36 29 32])
+
+(defconst ntlm-smb-perm3 [58 50 42 34 26 18 10 2
+ 60 52 44 36 28 20 12 4
+ 62 54 46 38 30 22 14 6
+ 64 56 48 40 32 24 16 8
+ 57 49 41 33 25 17 9 1
+ 59 51 43 35 27 19 11 3
+ 61 53 45 37 29 21 13 5
+ 63 55 47 39 31 23 15 7])
+
+(defconst ntlm-smb-perm4 [32 1 2 3 4 5
+ 4 5 6 7 8 9
+ 8 9 10 11 12 13
+ 12 13 14 15 16 17
+ 16 17 18 19 20 21
+ 20 21 22 23 24 25
+ 24 25 26 27 28 29
+ 28 29 30 31 32 1])
+
+(defconst ntlm-smb-perm5 [16 7 20 21
+ 29 12 28 17
+ 1 15 23 26
+ 5 18 31 10
+ 2 8 24 14
+ 32 27 3 9
+ 19 13 30 6
+ 22 11 4 25])
+
+(defconst ntlm-smb-perm6 [40 8 48 16 56 24 64 32
+ 39 7 47 15 55 23 63 31
+ 38 6 46 14 54 22 62 30
+ 37 5 45 13 53 21 61 29
+ 36 4 44 12 52 20 60 28
+ 35 3 43 11 51 19 59 27
+ 34 2 42 10 50 18 58 26
+ 33 1 41 9 49 17 57 25])
+
+(defconst ntlm-smb-sc [1 1 2 2 2 2 2 2 1 2 2 2 2 2 2 1])
+
+(defconst ntlm-smb-sbox [[[14 4 13 1 2 15 11 8 3 10 6 12 5 9 0 7]
+ [ 0 15 7 4 14 2 13 1 10 6 12 11 9 5 3 8]
+ [ 4 1 14 8 13 6 2 11 15 12 9 7 3 10 5 0]
+ [15 12 8 2 4 9 1 7 5 11 3 14 10 0 6 13]]
+ [[15 1 8 14 6 11 3 4 9 7 2 13 12 0 5 10]
+ [ 3 13 4 7 15 2 8 14 12 0 1 10 6 9 11 5]
+ [ 0 14 7 11 10 4 13 1 5 8 12 6 9 3 2 15]
+ [13 8 10 1 3 15 4 2 11 6 7 12 0 5 14 9]]
+ [[10 0 9 14 6 3 15 5 1 13 12 7 11 4 2 8]
+ [13 7 0 9 3 4 6 10 2 8 5 14 12 11 15 1]
+ [13 6 4 9 8 15 3 0 11 1 2 12 5 10 14 7]
+ [ 1 10 13 0 6 9 8 7 4 15 14 3 11 5 2 12]]
+ [[ 7 13 14 3 0 6 9 10 1 2 8 5 11 12 4 15]
+ [13 8 11 5 6 15 0 3 4 7 2 12 1 10 14 9]
+ [10 6 9 0 12 11 7 13 15 1 3 14 5 2 8 4]
+ [ 3 15 0 6 10 1 13 8 9 4 5 11 12 7 2 14]]
+ [[ 2 12 4 1 7 10 11 6 8 5 3 15 13 0 14 9]
+ [14 11 2 12 4 7 13 1 5 0 15 10 3 9 8 6]
+ [ 4 2 1 11 10 13 7 8 15 9 12 5 6 3 0 14]
+ [11 8 12 7 1 14 2 13 6 15 0 9 10 4 5 3]]
+ [[12 1 10 15 9 2 6 8 0 13 3 4 14 7 5 11]
+ [10 15 4 2 7 12 9 5 6 1 13 14 0 11 3 8]
+ [ 9 14 15 5 2 8 12 3 7 0 4 10 1 13 11 6]
+ [ 4 3 2 12 9 5 15 10 11 14 1 7 6 0 8 13]]
+ [[ 4 11 2 14 15 0 8 13 3 12 9 7 5 10 6 1]
+ [13 0 11 7 4 9 1 10 14 3 5 12 2 15 8 6]
+ [ 1 4 11 13 12 3 7 14 10 15 6 8 0 5 9 2]
+ [ 6 11 13 8 1 4 10 7 9 5 0 15 14 2 3 12]]
+ [[13 2 8 4 6 15 11 1 10 9 3 14 5 0 12 7]
+ [ 1 15 13 8 10 3 7 4 12 5 6 11 0 14 9 2]
+ [ 7 11 4 1 9 12 14 2 0 6 10 13 15 3 5 8]
+ [ 2 1 14 7 4 10 8 13 15 12 9 0 3 5 6 11]]])
+
+(defsubst ntlm-string-permute (in perm n)
+ "Return a string of length N for a string IN and a permutation vector
+PERM of size N. The length of IN should be height of PERM."
+ (let ((i 0) (out (make-string n 0)))
+ (while (< i n)
+ (aset out i (aref in (- (aref perm i) 1)))
+ (setq i (1+ i)))
+ out))
+
+(defsubst ntlm-string-lshift (str count len)
+ "Return a string by circularly shifting a string STR by COUNT to the left.
+length of STR is LEN."
+ (let ((c (% count len)))
+ (concat (substring str c len) (substring str 0 c))))
+
+(defsubst ntlm-string-xor (in1 in2 n)
+ "Return exclusive-or of sequences in1 and in2"
+ (let ((w (make-string n 0)) (i 0))
+ (while (< i n)
+ (aset w i (logxor (aref in1 i) (aref in2 i)))
+ (setq i (1+ i)))
+ w))
+
+(defun ntlm-smb-dohash (in key forw)
+ "Return the hash value for a string IN and a string KEY.
+Length of IN and KEY are 64. FORW non nill means forward, nil means
+backward."
+ (let (pk1 ;string of length 56
+ c ;string of length 28
+ d ;string of length 28
+ cd ;string of length 56
+ (ki (make-vector 16 0)) ;vector of string of length 48
+ pd1 ;string of length 64
+ l ;string of length 32
+ r ;string of length 32
+ rl ;string of length 64
+ (i 0) (j 0) (k 0))
+ (setq pk1 (ntlm-string-permute key ntlm-smb-perm1 56))
+ (setq c (substring pk1 0 28))
+ (setq d (substring pk1 28 56))
+
+ (setq i 0)
+ (while (< i 16)
+ (setq c (ntlm-string-lshift c (aref ntlm-smb-sc i) 28))
+ (setq d (ntlm-string-lshift d (aref ntlm-smb-sc i) 28))
+ (setq cd (concat (substring c 0 28) (substring d 0 28)))
+ (aset ki i (ntlm-string-permute cd ntlm-smb-perm2 48))
+ (setq i (1+ i)))
+
+ (setq pd1 (ntlm-string-permute in ntlm-smb-perm3 64))
+
+ (setq l (substring pd1 0 32))
+ (setq r (substring pd1 32 64))
+
+ (setq i 0)
+ (let (er ;string of length 48
+ erk ;string of length 48
+ (b (make-vector 8 0)) ;vector of strings of length 6
+ cb ;string of length 32
+ pcb ;string of length 32
+ r2 ;string of length 32
+ jj m n bj sbox-jmn)
+ (while (< i 16)
+ (setq er (ntlm-string-permute r ntlm-smb-perm4 48))
+ (setq erk (ntlm-string-xor er
+ (aref ki (if forw i (- 15 i)))
+ 48))
+ (setq j 0)
+ (while (< j 8)
+ (setq jj (* 6 j))
+ (aset b j (substring erk jj (+ jj 6)))
+ (setq j (1+ j)))
+ (setq j 0)
+ (while (< j 8)
+ (setq bj (aref b j))
+ (setq m (logior (lsh (aref bj 0) 1) (aref bj 5)))
+ (setq n (logior (lsh (aref bj 1) 3)
+ (lsh (aref bj 2) 2)
+ (lsh (aref bj 3) 1)
+ (aref bj 4)))
+ (setq k 0)
+ (setq sbox-jmn (aref (aref (aref ntlm-smb-sbox j) m) n))
+ (while (< k 4)
+ (aset bj k
+ (if (zerop (logand sbox-jmn (lsh 1 (- 3 k))))
+ 0 1))
+ (setq k (1+ k)))
+ (setq j (1+ j)))
+
+ (setq j 0)
+ (setq cb nil)
+ (while (< j 8)
+ (setq cb (concat cb (substring (aref b j) 0 4)))
+ (setq j (1+ j)))
+
+ (setq pcb (ntlm-string-permute cb ntlm-smb-perm5 32))
+ (setq r2 (ntlm-string-xor l pcb 32))
+ (setq l r)
+ (setq r r2)
+ (setq i (1+ i))))
+ (setq rl (concat r l))
+ (ntlm-string-permute rl ntlm-smb-perm6 64)))
+
+(defun ntlm-md4hash (passwd)
+ "Return the 16 bytes MD4 hash of a string PASSWD after converting it
+into a Unicode string. PASSWD is truncated to 128 bytes if longer."
+ (let (len wpwd)
+ ;; Password cannot be longer than 128 characters
+ (setq len (length passwd))
+ (if (> len 128)
+ (setq len 128))
+ ;; Password must be converted to NT unicode
+ (setq wpwd (ntlm-ascii2unicode passwd len))
+ ;; Calculate length in bytes
+ (setq len (* len 2))
+ (md4 wpwd len)))
+
+(provide 'ntlm)
+
+;;; ntlm.el ends here
;;; Code:
-(require 'custom)
-
(defgroup pgg ()
"Glue for the various PGP implementations."
:group 'mime)
;;; pgg-gpg.el --- GnuPG support for PGG.
-;; Copyright (C) 1999, 2000, 2003 Free Software Foundation, Inc.
+;; Copyright (C) 1999, 2000, 2003, 2004 Free Software Foundation, Inc.
;; Author: Daiki Ueno <ueno@unixuser.org>
;; Created: 1999/10/28
(with-temp-buffer
(apply #'call-process pgg-gpg-program nil t nil args)
(goto-char (point-min))
- (while (re-search-forward "^\\(sec\\|pub\\):" nil t)
- (push (substring
- (nth 3 (split-string
- (buffer-substring (match-end 0)
- (progn (end-of-line) (point)))
- ":")) 8)
+ (while (re-search-forward
+ "^\\(sec\\|pub\\):[^:]*:[^:]*:[^:]*:\\([^:]*\\)" nil t)
+ (push (substring (match-string 2) 8)
pgg-gpg-all-secret-keys)))))
pgg-gpg-all-secret-keys)
(with-temp-buffer
(apply #'call-process pgg-gpg-program nil t nil args)
(goto-char (point-min))
- (if (re-search-forward "^\\(sec\\|pub\\):" nil t)
- (substring
- (nth 3 (split-string
- (buffer-substring (match-end 0)
- (progn (end-of-line)(point)))
- ":")) 8)))))
+ (if (re-search-forward "^\\(sec\\|pub\\):[^:]*:[^:]*:[^:]*:\\([^:]*\\)"
+ nil t)
+ (substring (match-string 2) 8)))))
(defun pgg-gpg-encrypt-region (start end recipients &optional sign)
"Encrypt the current region between START and END.
(eval-when-compile (require 'cl))
-(require 'custom)
-
(defgroup pgg-parse ()
"OpenPGP packet parsing"
:group 'pgg)
;;; pgg.el --- glue for the various PGP implementations.
-;; Copyright (C) 1999, 2000, 2003 Free Software Foundation, Inc.
+;; Copyright (C) 1999, 2000, 2003, 2004 Free Software Foundation, Inc.
;; Author: Daiki Ueno <ueno@unixuser.org>
;; Created: 1999/10/28
(require 'pgg-def)
(require 'pgg-parse)
-(autoload 'run-at-time "timer")
+(require 'password)
;; Don't merge these two `eval-when-compile's.
(eval-when-compile
(set-buffer standard-output)
(insert-buffer-substring pgg-errors-buffer)))))
-(defvar pgg-passphrase-cache (make-vector 7 0))
-
(defun pgg-read-passphrase (prompt &optional key)
- (or (and pgg-cache-passphrase
- key (setq key (pgg-truncate-key-identifier key))
- (symbol-value (intern-soft key pgg-passphrase-cache)))
- (read-passwd prompt)))
-
-(eval-when-compile
- (defvar itimer-process)
- (defvar itimer-timer)
- (autoload 'delete-itimer "itimer")
- (autoload 'itimer-driver-start "itimer")
- (autoload 'itimer-value "itimer")
- (autoload 'set-itimer-function "itimer")
- (autoload 'set-itimer-function-arguments "itimer")
- (autoload 'set-itimer-restart "itimer")
- (autoload 'start-itimer "itimer"))
-
-(eval-and-compile
- (defalias
- 'pgg-run-at-time
- (if (featurep 'xemacs)
- (if (condition-case nil
- (progn
- (unless (or itimer-process itimer-timer)
- (itimer-driver-start))
- ;; Check whether there is a bug to which the difference of
- ;; the present time and the time when the itimer driver was
- ;; woken up is subtracted from the initial itimer value.
- (let* ((inhibit-quit t)
- (ctime (current-time))
- (itimer-timer-last-wakeup
- (prog1
- ctime
- (setcar ctime (1- (car ctime)))))
- (itimer-list nil)
- (itimer (start-itimer "pgg-run-at-time" 'ignore 5)))
- (sleep-for 0.1) ;; Accept the timeout interrupt.
- (prog1
- (> (itimer-value itimer) 0)
- (delete-itimer itimer))))
- (error nil))
- (lambda (time repeat function &rest args)
- "Emulating function run as `run-at-time'.
-TIME should be nil meaning now, or a number of seconds from now.
-Return an itimer object which can be used in either `delete-itimer'
-or `cancel-timer'."
- (apply #'start-itimer "pgg-run-at-time"
- function (if time (max time 1e-9) 1e-9)
- repeat nil t args))
- (lambda (time repeat function &rest args)
- "Emulating function run as `run-at-time' in the right way.
-TIME should be nil meaning now, or a number of seconds from now.
-Return an itimer object which can be used in either `delete-itimer'
-or `cancel-timer'."
- (let ((itimers (list nil)))
- (setcar
- itimers
- (apply #'start-itimer "pgg-run-at-time"
- (lambda (itimers repeat function &rest args)
- (let ((itimer (car itimers)))
- (if repeat
- (progn
- (set-itimer-function
- itimer
- (lambda (itimer repeat function &rest args)
- (set-itimer-restart itimer repeat)
- (set-itimer-function itimer function)
- (set-itimer-function-arguments itimer args)
- (apply function args)))
- (set-itimer-function-arguments
- itimer
- (append (list itimer repeat function) args)))
- (set-itimer-function
- itimer
- (lambda (itimer function &rest args)
- (delete-itimer itimer)
- (apply function args)))
- (set-itimer-function-arguments
- itimer
- (append (list itimer function) args)))))
- 1e-9 (if time (max time 1e-9) 1e-9)
- nil t itimers repeat function args)))))
- 'run-at-time)))
+ (when pgg-cache-passphrase
+ (password-read prompt (setq key (pgg-truncate-key-identifier key)))))
(defun pgg-add-passphrase-cache (key passphrase)
- (setq key (pgg-truncate-key-identifier key))
- (set (intern key pgg-passphrase-cache)
- passphrase)
- (pgg-run-at-time pgg-passphrase-cache-expiry nil
- #'pgg-remove-passphrase-cache
- key))
+ (let ((password-cache-expiry pgg-passphrase-cache-expiry))
+ (password-cache-add (setq key (pgg-truncate-key-identifier key))
+ passphrase)))
(defun pgg-remove-passphrase-cache (key)
- (let ((passphrase (symbol-value (intern-soft key pgg-passphrase-cache))))
- (when passphrase
- (fillarray passphrase ?_)
- (unintern key pgg-passphrase-cache))))
+ (password-cache-remove key))
(defmacro pgg-convert-lbt-region (start end lbt)
`(let ((pgg-conversion-end (set-marker (make-marker) ,end)))
--- /dev/null
+;;; sasl-cram.el --- CRAM-MD5 module for the SASL client framework
+
+;; Copyright (C) 2000 Free Software Foundation, Inc.
+
+;; Author: Daiki Ueno <ueno@unixuser.org>
+;; Kenichi OKADA <okada@opaopa.org>
+;; Keywords: SASL, CRAM-MD5
+
+;; 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:
+
+(require 'sasl)
+(require 'hmac-md5)
+
+(defconst sasl-cram-md5-steps
+ '(ignore ;no initial response
+ sasl-cram-md5-response))
+
+(defun sasl-cram-md5-response (client step)
+ (let ((passphrase
+ (sasl-read-passphrase
+ (format "CRAM-MD5 passphrase for %s: "
+ (sasl-client-name client)))))
+ (unwind-protect
+ (concat (sasl-client-name client) " "
+ (encode-hex-string
+ (hmac-md5 (sasl-step-data step) passphrase)))
+ (fillarray passphrase 0))))
+
+(put 'sasl-cram 'sasl-mechanism
+ (sasl-make-mechanism "CRAM-MD5" sasl-cram-md5-steps))
+
+(provide 'sasl-cram)
+
+;;; sasl-cram.el ends here
--- /dev/null
+;;; sasl-digest.el --- DIGEST-MD5 module for the SASL client framework
+
+;; Copyright (C) 2000 Free Software Foundation, Inc.
+
+;; Author: Daiki Ueno <ueno@unixuser.org>
+;; Kenichi OKADA <okada@opaopa.org>
+;; Keywords: SASL, DIGEST-MD5
+
+;; 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.
+
+;; This program is implemented from draft-leach-digest-sasl-05.txt.
+;;
+;; It is caller's responsibility to base64-decode challenges and
+;; base64-encode responses in IMAP4 AUTHENTICATE command.
+;;
+;; Passphrase should be longer than 16 bytes. (See RFC 2195)
+
+;;; Commentary:
+
+(require 'sasl)
+(require 'hmac-md5)
+
+(defvar sasl-digest-md5-nonce-count 1)
+(defvar sasl-digest-md5-unique-id-function
+ sasl-unique-id-function)
+
+(defvar sasl-digest-md5-syntax-table
+ (let ((table (make-syntax-table)))
+ (modify-syntax-entry ?= "." table)
+ (modify-syntax-entry ?, "." table)
+ table)
+ "A syntax table for parsing digest-challenge attributes.")
+
+(defconst sasl-digest-md5-steps
+ '(ignore ;no initial response
+ sasl-digest-md5-response
+ ignore)) ;""
+
+(defun sasl-digest-md5-parse-string (string)
+ "Parse STRING and return a property list.
+The value is a cons cell of the form \(realm nonce qop-options stale maxbuf
+charset algorithm cipher-opts auth-param)."
+ (with-temp-buffer
+ (set-syntax-table sasl-digest-md5-syntax-table)
+ (save-excursion
+ (insert string)
+ (goto-char (point-min))
+ (insert "(")
+ (while (progn (forward-sexp) (not (eobp)))
+ (delete-char 1)
+ (insert " "))
+ (insert ")")
+ (read (point-min-marker)))))
+
+(defun sasl-digest-md5-digest-uri (serv-type host &optional serv-name)
+ (concat serv-type "/" host
+ (if (and serv-name
+ (not (string= host serv-name)))
+ (concat "/" serv-name))))
+
+(defun sasl-digest-md5-cnonce ()
+ (let ((sasl-unique-id-function sasl-digest-md5-unique-id-function))
+ (sasl-unique-id)))
+
+(defun sasl-digest-md5-response-value (username
+ realm
+ nonce
+ cnonce
+ nonce-count
+ qop
+ digest-uri
+ authzid)
+ (let ((passphrase
+ (sasl-read-passphrase
+ (format "DIGEST-MD5 passphrase for %s: "
+ username))))
+ (unwind-protect
+ (encode-hex-string
+ (md5-binary
+ (concat
+ (encode-hex-string
+ (md5-binary (concat (md5-binary
+ (concat username ":" realm ":" passphrase))
+ ":" nonce ":" cnonce
+ (if authzid
+ (concat ":" authzid)))))
+ ":" nonce
+ ":" (format "%08x" nonce-count) ":" cnonce ":" qop ":"
+ (encode-hex-string
+ (md5-binary
+ (concat "AUTHENTICATE:" digest-uri
+ (if (member qop '("auth-int" "auth-conf"))
+ ":00000000000000000000000000000000")))))))
+ (fillarray passphrase 0))))
+
+(defun sasl-digest-md5-response (client step)
+ (let* ((plist
+ (sasl-digest-md5-parse-string (sasl-step-data step)))
+ (realm
+ (or (sasl-client-property client 'realm)
+ (plist-get plist 'realm))) ;need to check
+ (nonce-count
+ (or (sasl-client-property client 'nonce-count)
+ sasl-digest-md5-nonce-count))
+ (qop
+ (or (sasl-client-property client 'qop)
+ "auth"))
+ (digest-uri
+ (sasl-digest-md5-digest-uri
+ (sasl-client-service client)(sasl-client-server client)))
+ (cnonce
+ (or (sasl-client-property client 'cnonce)
+ (sasl-digest-md5-cnonce))))
+ (sasl-client-set-property client 'nonce-count (1+ nonce-count))
+ (unless (string= qop "auth")
+ (sasl-error (format "Unsupported \"qop-value\": %s" qop)))
+ (concat
+ "username=\"" (sasl-client-name client) "\","
+ "realm=\"" realm "\","
+ "nonce=\"" (plist-get plist 'nonce) "\","
+ "cnonce=\"" cnonce "\","
+ (format "nc=%08x," nonce-count)
+ "digest-uri=\"" digest-uri "\","
+ "qop=" qop ","
+ "response="
+ (sasl-digest-md5-response-value
+ (sasl-client-name client)
+ realm
+ (plist-get plist 'nonce)
+ cnonce
+ nonce-count
+ qop
+ digest-uri
+ (plist-get plist 'authzid)))))
+
+(put 'sasl-digest 'sasl-mechanism
+ (sasl-make-mechanism "DIGEST-MD5" sasl-digest-md5-steps))
+
+(provide 'sasl-digest)
+
+;;; sasl-digest.el ends here
--- /dev/null
+;;; sasl-ntlm.el --- NTLM (NT Lan Manager) module for the SASL client framework
+
+;; Copyright (C) 2000 Free Software Foundation, Inc.
+
+;; Author: Taro Kawagishi <tarok@transpulse.org>
+;; Keywords: SASL, NTLM
+;; Version: 1.00
+;; Created: February 2001
+
+;; 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 is a SASL interface layer for NTLM authentication message
+;; generation by ntlm.el
+
+;;; Code:
+
+(require 'sasl)
+(require 'ntlm)
+
+(defconst sasl-ntlm-steps
+ '(ignore ;nothing to do before making
+ sasl-ntlm-request ;authentication request
+ sasl-ntlm-response) ;response to challenge
+ "A list of functions to be called in sequnece for the NTLM
+authentication steps. Ther are called by 'sasl-next-step.")
+
+(defun sasl-ntlm-request (client step)
+ "SASL step function to generate a NTLM authentication request to the server.
+Called from 'sasl-next-step.
+CLIENT is a vector [mechanism user service server sasl-client-properties]
+STEP is a vector [<previous step function> <result of previous step function>]"
+ (let ((user (sasl-client-name client)))
+ (ntlm-build-auth-request user)))
+
+(defun sasl-ntlm-response (client step)
+ "SASL step function to generate a NTLM response against the server
+challenge stored in the 2nd element of STEP. Called from 'sasl-next-step."
+ (let* ((user (sasl-client-name client))
+ (passphrase
+ (sasl-read-passphrase (format "NTLM passphrase for %s: " user)))
+ (challenge (sasl-step-data step)))
+ (ntlm-build-auth-response challenge user
+ (ntlm-get-password-hashes passphrase))))
+
+(put 'sasl-ntlm 'sasl-mechanism
+ (sasl-make-mechanism "NTLM" sasl-ntlm-steps))
+
+(provide 'sasl-ntlm)
+
+;;; sasl-ntlm.el ends here
--- /dev/null
+;;; sasl.el --- SASL client framework
+
+;; Copyright (C) 2000 Free Software Foundation, Inc.
+
+;; Author: Daiki Ueno <ueno@unixuser.org>
+;; Keywords: SASL
+
+;; 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 module provides common interface functions to share several
+;; SASL mechanism drivers. The toplevel is designed to be mostly
+;; compatible with [Java-SASL].
+;;
+;; [SASL] J. Myers, "Simple Authentication and Security Layer (SASL)",
+;; RFC 2222, October 1997.
+;;
+;; [Java-SASL] R. Weltman & R. Lee, "The Java SASL Application Program
+;; Interface", draft-weltman-java-sasl-03.txt, March 2000.
+
+;;; Code:
+
+(defvar sasl-mechanisms
+ '("CRAM-MD5" "DIGEST-MD5" "PLAIN" "LOGIN" "ANONYMOUS"
+ "NTLM" "SCRAM-MD5"))
+
+(defvar sasl-mechanism-alist
+ '(("CRAM-MD5" sasl-cram)
+ ("DIGEST-MD5" sasl-digest)
+ ("PLAIN" sasl-plain)
+ ("LOGIN" sasl-login)
+ ("ANONYMOUS" sasl-anonymous)
+ ("NTLM" sasl-ntlm)
+ ("SCRAM-MD5" sasl-scram)))
+
+(defvar sasl-unique-id-function #'sasl-unique-id-function)
+
+(put 'sasl-error 'error-message "SASL error")
+(put 'sasl-error 'error-conditions '(sasl-error error))
+
+(defun sasl-error (datum)
+ (signal 'sasl-error (list datum)))
+
+;;; @ SASL client
+;;;
+
+(defun sasl-make-client (mechanism name service server)
+ "Return a newly allocated SASL client.
+NAME is name of the authorization. SERVICE is name of the service desired.
+SERVER is the fully qualified host name of the server to authenticate to."
+ (vector mechanism name service server (make-symbol "sasl-client-properties")))
+
+(defun sasl-client-mechanism (client)
+ "Return the authentication mechanism driver of CLIENT."
+ (aref client 0))
+
+(defun sasl-client-name (client)
+ "Return the authorization name of CLIENT, a string."
+ (aref client 1))
+
+(defun sasl-client-service (client)
+ "Return the service name of CLIENT, a string."
+ (aref client 2))
+
+(defun sasl-client-server (client)
+ "Return the server name of CLIENT, a string."
+ (aref client 3))
+
+(defun sasl-client-set-properties (client plist)
+ "Destructively set the properties of CLIENT.
+The second argument PLIST is the new property list."
+ (setplist (aref client 4) plist))
+
+(defun sasl-client-set-property (client property value)
+ "Add the given property/value to CLIENT."
+ (put (aref client 4) property value))
+
+(defun sasl-client-property (client property)
+ "Return the value of the PROPERTY of CLIENT."
+ (get (aref client 4) property))
+
+(defun sasl-client-properties (client)
+ "Return the properties of CLIENT."
+ (symbol-plist (aref client 4)))
+
+;;; @ SASL mechanism
+;;;
+
+(defun sasl-make-mechanism (name steps)
+ "Make an authentication mechanism.
+NAME is a IANA registered SASL mechanism name.
+STEPS is list of continuation function."
+ (vector name
+ (mapcar
+ (lambda (step)
+ (let ((symbol (make-symbol (symbol-name step))))
+ (fset symbol (symbol-function step))
+ symbol))
+ steps)))
+
+(defun sasl-mechanism-name (mechanism)
+ "Return name of MECHANISM, a string."
+ (aref mechanism 0))
+
+(defun sasl-mechanism-steps (mechanism)
+ "Return the authentication steps of MECHANISM, a list of functions."
+ (aref mechanism 1))
+
+(defun sasl-find-mechanism (mechanisms)
+ "Retrieve an apropriate mechanism object from MECHANISMS hints."
+ (let* ((sasl-mechanisms sasl-mechanisms)
+ (mechanism
+ (catch 'done
+ (while sasl-mechanisms
+ (if (member (car sasl-mechanisms) mechanisms)
+ (throw 'done (nth 1 (assoc (car sasl-mechanisms)
+ sasl-mechanism-alist))))
+ (setq sasl-mechanisms (cdr sasl-mechanisms))))))
+ (if mechanism
+ (require mechanism))
+ (get mechanism 'sasl-mechanism)))
+
+;;; @ SASL authentication step
+;;;
+
+(defun sasl-step-data (step)
+ "Return the data which STEP holds, a string."
+ (aref step 1))
+
+(defun sasl-step-set-data (step data)
+ "Store DATA string to STEP."
+ (aset step 1 data))
+
+(defun sasl-next-step (client step)
+ "Evaluate the challenge and prepare an appropriate next response.
+The data type of the value and optional 2nd argument STEP is nil or
+opaque authentication step which holds the reference to the next action
+and the current challenge. At the first time STEP should be set to nil."
+ (let* ((steps
+ (sasl-mechanism-steps
+ (sasl-client-mechanism client)))
+ (function
+ (if (vectorp step)
+ (nth 1 (memq (aref step 0) steps))
+ (car steps))))
+ (if function
+ (vector function (funcall function client step)))))
+
+(defvar sasl-read-passphrase nil)
+(defun sasl-read-passphrase (prompt)
+ (if (not sasl-read-passphrase)
+ (if (functionp 'read-passwd)
+ (setq sasl-read-passphrase 'read-passwd)
+ (if (load "passwd" t)
+ (setq sasl-read-passphrase 'read-passwd)
+ (autoload 'ange-ftp-read-passwd "ange-ftp")
+ (setq sasl-read-passphrase 'ange-ftp-read-passwd))))
+ (funcall sasl-read-passphrase prompt))
+
+(defun sasl-unique-id ()
+ "Compute a data string which must be different each time.
+It contain at least 64 bits of entropy."
+ (concat (funcall sasl-unique-id-function)(funcall sasl-unique-id-function)))
+
+(defvar sasl-unique-id-char nil)
+
+;; stolen (and renamed) from message.el
+(defun sasl-unique-id-function ()
+ ;; Don't use microseconds from (current-time), they may be unsupported.
+ ;; Instead we use this randomly inited counter.
+ (setq sasl-unique-id-char
+ (% (1+ (or sasl-unique-id-char (logand (random t) (1- (lsh 1 20)))))
+ ;; (current-time) returns 16-bit ints,
+ ;; and 2^16*25 just fits into 4 digits i base 36.
+ (* 25 25)))
+ (let ((tm (current-time)))
+ (concat
+ (sasl-unique-id-number-base36
+ (+ (car tm)
+ (lsh (% sasl-unique-id-char 25) 16)) 4)
+ (sasl-unique-id-number-base36
+ (+ (nth 1 tm)
+ (lsh (/ sasl-unique-id-char 25) 16)) 4))))
+
+(defun sasl-unique-id-number-base36 (num len)
+ (if (if (< len 0)
+ (<= num 0)
+ (= len 0))
+ ""
+ (concat (sasl-unique-id-number-base36 (/ num 36) (1- len))
+ (char-to-string (aref "zyxwvutsrqponmlkjihgfedcba9876543210"
+ (% num 36))))))
+
+;;; PLAIN (RFC2595 Section 6)
+(defconst sasl-plain-steps
+ '(sasl-plain-response))
+
+(defun sasl-plain-response (client step)
+ (let ((passphrase
+ (sasl-read-passphrase
+ (format "PLAIN passphrase for %s: " (sasl-client-name client))))
+ (authenticator-name
+ (sasl-client-property
+ client 'authenticator-name))
+ (name (sasl-client-name client)))
+ (unwind-protect
+ (if (and authenticator-name
+ (not (string= authenticator-name name)))
+ (concat authenticator-name "\0" name "\0" passphrase)
+ (concat "\0" name "\0" passphrase))
+ (fillarray passphrase 0))))
+
+(put 'sasl-plain 'sasl-mechanism
+ (sasl-make-mechanism "PLAIN" sasl-plain-steps))
+
+(provide 'sasl-plain)
+
+;;; LOGIN (No specification exists)
+(defconst sasl-login-steps
+ '(ignore ;no initial response
+ sasl-login-response-1
+ sasl-login-response-2))
+
+(defun sasl-login-response-1 (client step)
+;;; (unless (string-match "^Username:" (sasl-step-data step))
+;;; (sasl-error (format "Unexpected response: %s" (sasl-step-data step))))
+ (sasl-client-name client))
+
+(defun sasl-login-response-2 (client step)
+;;; (unless (string-match "^Password:" (sasl-step-data step))
+;;; (sasl-error (format "Unexpected response: %s" (sasl-step-data step))))
+ (sasl-read-passphrase
+ (format "LOGIN passphrase for %s: " (sasl-client-name client))))
+
+(put 'sasl-login 'sasl-mechanism
+ (sasl-make-mechanism "LOGIN" sasl-login-steps))
+
+(provide 'sasl-login)
+
+;;; ANONYMOUS (RFC2245)
+(defconst sasl-anonymous-steps
+ '(ignore ;no initial response
+ sasl-anonymous-response))
+
+(defun sasl-anonymous-response (client step)
+ (or (sasl-client-property client 'trace)
+ (sasl-client-name client)))
+
+(put 'sasl-anonymous 'sasl-mechanism
+ (sasl-make-mechanism "ANONYMOUS" sasl-anonymous-steps))
+
+(provide 'sasl-anonymous)
+
+(provide 'sasl)
+
+;;; sasl.el ends here
gnus-[0-9]*
message
message-[0-9]*
+sasl
sieve
pgg
gnustmp.texi
%% include file for the Gnus refcard and booklet
\def\progver{5.10}\def\refver{5.10-1} % program and refcard versions
-\def\date{Oct, 2003}
+\def\date{Jan, 2004}
\def\author{Gnus Bugfixing Girls + Boys $<$bugs@gnus.org$>$}
%%
Copyright \copyright\ 1995 Vladimir Alexiev
$<$vladimir@cs.ualberta.ca$>$.\\*
Copyright \copyright\ 2000 Felix Natter $<$fnatter@gmx.net$>$.\\*
- Copyright \copyright\ 2001, 2002, 2003 \author.\\*
+ Copyright \copyright\ 2001, 2002, 2003, 2004 \author.\\*
Created from the Gnus manual Copyright \copyright\ 1994 Lars Magne
Ingebrigtsen.\\*
and the Emacs Help Bindings feature (C-h b).\\*
/o & Insert all {\bf old} articles. [Prefix: how many]\\
/N & Insert all {\bf new} articles.\\
/p & Limit to articles {\bf predicated} in the `display' group parameter.\\
+ /r & Limit to {\bf replied} articles. [Prefix: unreplied]\\
\end{keys}
}
}
@ifinfo
This file describes the PGG.
-Copyright (C) 2003 Free Software Foundation, Inc.
+Copyright (C) 2003, 2004 Free Software Foundation, Inc.
Copyright (C) 2001 Daiki Ueno.
Permission is granted to copy, distribute and/or modify this document
If encryption is successful, it replaces the current region contents (in
the accessible portion) with the resulting data.
-If optional argument @var{sign} is non-nil, the function is request to
-do a combined sign and encrypt. This currently only work with GnuPG.
+If optional argument @var{sign} is non-@code{nil}, the function is
+request to do a combined sign and encrypt. This currently only work
+with GnuPG.
@end deffn
@deffn Command pgg-decrypt-region start end
@node Caching passphrase
@section Caching passphrase
-PGG provides a simple passphrase caching mechanism. If you want to
-arrange the interaction, set the variable @code{pgg-read-passphrase}.
+PGG uses a simple passphrase caching mechanism, which is enabled by
+default.
@defvar pgg-cache-passphrase
If non-@code{nil}, store passphrases. The default value of this
@deffn Method pgg-scheme-encrypt-region scheme start end recipients &optional sign
Encrypt the current region between @var{start} and @var{end} for
-@var{recipients}. If @var{sign} is non-nil, do a combined sign and
-encrypt. If encryption is successful, it returns @code{t}, otherwise
-@code{nil}.
+@var{recipients}. If @var{sign} is non-@code{nil}, do a combined sign
+and encrypt. If encryption is successful, it returns @code{t},
+otherwise @code{nil}.
@end deffn
@deffn Method pgg-scheme-decrypt-region scheme start end
projects / elisp / gnus.git- / commitdiff