-;;; wl-address.el -- Tiny address management for Wanderlust.
+;;; wl-address.el --- Tiny address management for Wanderlust.
;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
;; Copyright (C) 1998,1999,2000 Shun-ichi GOTO <gotoh@taiyo.co.jp>
;;
;;; Commentary:
-;;
+;;
;;; Code:
-;;
+;;
(require 'wl-util)
(require 'wl-vars)
(require 'std11)
-(defvar wl-address-complete-header-regexp "^\\(To\\|From\\|Cc\\|Bcc\\|Mail-Followup-To\\|Reply-To\\|Return-Receipt-To\\):")
+(defvar wl-address-complete-header-list
+ '("To:" "From:" "Cc:" "Bcc:" "Mail-Followup-To:" "Reply-To:"
+ "Return-Receipt-To:"))
+(defvar wl-address-complete-header-regexp nil) ; auto-generated.
(defvar wl-newsgroups-complete-header-regexp "^\\(Newsgroups\\|Followup-To\\):")
-(defvar wl-folder-complete-header-regexp "^\\(FCC\\):")
+(defvar wl-folder-complete-header-regexp "^\\(Fcc\\):")
(defvar wl-address-list nil)
(defvar wl-address-completion-list nil)
(defvar wl-address-petname-hash nil)
+(defvar wl-address-enable-strict-loading t)
(defvar wl-address-ldap-search-hash nil)
(defconst wl-ldap-alias-sep "/")
(defconst wl-ldap-search-attribute-type-list
- '("sn" "cn" "mail"))
+ '("sn" "cn" "mail" "email"))
(defun wl-ldap-get-value (type entry)
""
values nil)
(setq values (cdr values)))))
ret))
-
+
(defun wl-ldap-get-value-list (type entry)
""
(cdr (assoc type entry)))
(defun wl-ldap-make-filter (pat type-list)
"Make RFC1558 quiery filter for PAT from ATTR-LIST.
Each are \"OR\" combination, and PAT is beginning-match."
- (concat "(&(objectclass=" wl-ldap-objectclass ")(|"
+ (concat "(|"
(mapconcat (lambda (x) (format "(%s=%s*)" x pat)) ; fixed format
type-list
"")
- "))"))
+ ")"))
(defun wl-ldap-make-matched-value-list (regexp type-list entry)
"Correct matching WORD with value of TYPE-LIST in ENTRY.
(cdr (car entry)))
values (elmo-flatten values)
entry (cdr entry))
- (if (string-match "::?$" type)
- (setq type (substring type 0 (match-beginning 0))))
(if (member type type-list)
(while values
(setq val (car values)
"Modify STR for alias.
Replace space/tab in STR into '_' char.
Replace '@' in STR into list of mailbox and sub-domains."
- (while (string-match "[^_a-zA-Z0-9+@%.!\\-/]+" str)
+ (while (string-match "[ \t]+" str)
(setq str (concat (substring str 0 (match-beginning 0))
"_"
(substring str (match-end 0)))))
(let ((pat (if (string-match wl-ldap-alias-sep pattern)
(substring pattern 0 (match-beginning 0))
pattern))
- (ldap-default-host wl-ldap-server)
- (ldap-default-port (or wl-ldap-port 389))
- (ldap-default-base wl-ldap-base)
+ (ldap-default-host (or wl-ldap-server ldap-default-host "localhost"))
+ (ldap-default-port (or wl-ldap-port ldap-default-port 389))
+ (ldap-default-base (or wl-ldap-base ldap-default-base))
(dnhash (elmo-make-hash))
cache len sym tmpl regexp entries ent values dn dnstr alias
result cn mails)
;; get matched entries
(if cache
(setq entries (cdr cache))
- (condition-case nil
- (progn
- (message "Searching in LDAP...")
- (setq entries (ldap-search-entries
- (wl-ldap-make-filter
- (concat pat "*")
- wl-ldap-search-attribute-type-list)
- nil wl-ldap-search-attribute-type-list nil t))
- (message "Searching in LDAP...done")
- (elmo-set-hash-val pattern entries wl-address-ldap-search-hash))
- (error (message "")))) ; ignore error: No such object
+ (ignore-errors
+ (message "Searching in LDAP...")
+ (setq entries (ldap-search-entries
+ (wl-ldap-make-filter
+ pat wl-ldap-search-attribute-type-list)
+ nil wl-ldap-search-attribute-type-list nil t))
+ (message "Searching in LDAP...done")
+ (elmo-set-hash-val pattern entries wl-address-ldap-search-hash)))
;;
(setq tmpl entries)
(while tmpl
(while entries
(setq ent (cdar entries)
values (wl-ldap-make-matched-value-list
- regexp '("mail" "sn" "cn") ent)
- mails (wl-ldap-get-value-list "mail" ent)
+ regexp wl-ldap-search-attribute-type-list
+ ent)
+ mails (or (wl-ldap-get-value-list "mail" ent)
+ (wl-ldap-get-value-list "email" ent))
cn (wl-ldap-get-value "cn" ent)
dn (car (car entries))
dnstr (elmo-get-hash-val (upcase dn) dnhash))
(setq entries (cdr entries)))
(append result cl)))
-(defun wl-complete-field-to ()
- (interactive)
- (let ((cl wl-address-completion-list))
- (if cl
- (completing-read "To: " cl)
- (read-string "To: "))))
-
-(defun wl-address-quote-specials (word)
- "Make quoted string of WORD if needed."
- (let ((lal (std11-lexical-analyze word)))
- (if (or (assq 'specials lal)
- (assq 'domain-literal lal))
- (prin1-to-string word)
- word)))
+(defun wl-complete-address (string predicate flag)
+ "Completion function for completing-read (comma separated addresses)."
+ (if (string-match "^\\(.*,\\)\\(.*\\)$" string)
+ (let* ((str1 (match-string 1 string))
+ (str2 (match-string 2 string))
+ (str2-comp (wl-complete-address str2 predicate flag)))
+ (if (and (not flag) (stringp str2-comp))
+ (concat str1 str2-comp)
+ str2-comp))
+ (if (not flag)
+ (try-completion string wl-address-list)
+ (all-completions string wl-address-list))))
+
+(defalias 'wl-address-quote-specials 'elmo-address-quote-specials)
(defun wl-address-make-completion-list (address-list)
(let (addr-tuple cl)
(while address-list
(setq addr-tuple (car address-list))
(setq cl
- (cons
- (cons (nth 0 addr-tuple)
- (concat
- (wl-address-quote-specials
- (nth 2 addr-tuple)) " <"(nth 0 addr-tuple)">"))
- cl))
+ (cons
+ (wl-address-make-completion-entry 0 addr-tuple)
+ cl))
;; nickname completion.
- (unless (or (equal (nth 1 addr-tuple) (nth 0 addr-tuple))
- ;; already exists
- (assoc (nth 1 addr-tuple) cl))
+ (if wl-address-enable-strict-loading
+ (unless (or (equal (nth 1 addr-tuple) (nth 0 addr-tuple))
+ ;; already exists
+ (assoc (nth 1 addr-tuple) cl))
+ (setq cl
+ (cons
+ (wl-address-make-completion-entry 1 addr-tuple)
+ cl)))
(setq cl
(cons
- (cons (nth 1 addr-tuple)
- (concat
- (wl-address-quote-specials
- (nth 2 addr-tuple)) " <"(nth 0 addr-tuple)">"))
+ (wl-address-make-completion-entry 1 addr-tuple)
cl)))
(setq address-list (cdr address-list)))
cl))
+(defun wl-address-make-completion-entry (index addr-tuple)
+ (cons (nth index addr-tuple)
+ (if (or (string= (nth 2 addr-tuple) "")
+ (string-match ".*:.*;$" (nth 0 addr-tuple)))
+ (nth 0 addr-tuple)
+ (concat
+ (wl-address-quote-specials
+ (nth 2 addr-tuple)) " <"(nth 0 addr-tuple)">"))))
+
(defun wl-complete-field-body-or-tab ()
(interactive)
(let ((case-fold-search t)
(with-output-to-temp-buffer
wl-completion-buf-name
(display-completion-list all))
- (message "Making completion list... done")))
+ (message "Making completion list...done")))
(defun wl-complete-window-delete ()
(let (comp-buf comp-win)
(if (null cl)
nil
(setq completion
- (let ((completion-ignore-case t))
- (try-completion pattern cl)))
+ (let ((completion-ignore-case t))
+ (try-completion pattern cl)))
(cond ((eq completion t)
(let ((alias (assoc pattern cl)))
(if alias
(completion)
(pattern (buffer-substring start end))
(len (length pattern))
+ (completion-ignore-case t)
(cl completion-list))
(when use-ldap
(setq cl (wl-address-ldap-search pattern cl)))
(message "Sole completion"))
((and epand-char
(> len 0)
- (char-equal (aref pattern (1- len)) epand-char)
+ (or (char-equal (aref pattern (1- len)) epand-char)
+ (char-equal (aref pattern (1- len)) ?\ ))
(assoc (substring pattern 0 (1- len)) cl))
(wl-complete-insert
start end
(when (< nest-count 5)
(let (expn-str new-expn-str expn new-expn(n 0) (expanded nil))
(while (setq expn-str (cdr (nth n alist)))
- (setq new-expn-str nil)
- (while (string-match "^[ \t]*\\([^,]+\\)" expn-str)
- (setq expn (elmo-match-string 1 expn-str))
+ (setq new-expn-str nil)
+ (while (string-match "^[ \t]*\\([^,]+\\)" expn-str)
+ (setq expn (elmo-match-string 1 expn-str))
(setq expn-str (wl-string-delete-match expn-str 0))
- (if (string-match "^[ \t,]+" expn-str)
+ (if (string-match "^[ \t,]+" expn-str)
(setq expn-str (wl-string-delete-match expn-str 0)))
- (if (string-match "[ \t,]+$" expn)
+ (if (string-match "[ \t,]+$" expn)
(setq expn (wl-string-delete-match expn 0)))
- (setq new-expn (cdr (assoc expn alist)))
- (if new-expn
- (setq expanded t))
- (setq new-expn-str (concat new-expn-str (and new-expn-str ", ")
- (or new-expn expn))))
- (when new-expn-str
- (setcdr (nth n alist) new-expn-str))
- (setq n (1+ n)))
+ (setq new-expn (cdr (assoc expn alist)))
+ (if new-expn
+ (setq expanded t))
+ (setq new-expn-str (concat new-expn-str (and new-expn-str ", ")
+ (or new-expn expn))))
+ (when new-expn-str
+ (setcdr (nth n alist) new-expn-str))
+ (setq n (1+ n)))
(and expanded
- (wl-address-expand-aliases alist (1+ nest-count))))))
+ (wl-address-expand-aliases alist (1+ nest-count))))))
(defun wl-address-make-alist-from-alias-file (file)
(elmo-set-work-buf
(while (re-search-forward ",$" nil t)
(end-of-line)
(forward-char 1)
- (delete-backward-char 1))
+ (delete-backward-char 1))
(goto-char (point-min))
(while (re-search-forward "^\\([^#;\n][^:]+\\):[ \t]*\\(.*\\)$" nil t)
(setq alias (wl-match-buffer 1)
(if (looking-at
"^\\([^#\n][^ \t\n]+\\)[ \t]+\\(\".*\"\\)[ \t]+\\(\".*\"\\)[ \t]*.*$")
(setq ret
- (wl-append-element
- ret
+ (cons
(list (wl-match-buffer 1)
(read (wl-match-buffer 2))
- (read (wl-match-buffer 3))))))
+ (read (wl-match-buffer 3)))
+ ret)))
(forward-line))
- ret))))
+ (nreverse ret)))))
-(defun wl-address-get-petname-1 (string)
- (let ((address (downcase (wl-address-header-extract-address string))))
- (elmo-get-hash-val address wl-address-petname-hash)))
-
-(defsubst wl-address-get-petname (string)
- (or (wl-address-get-petname-1 string)
- string))
-
-(defsubst wl-address-user-mail-address-p (address)
- "Judge whether ADDRESS is user's or not."
- (member (downcase (wl-address-header-extract-address address))
- (or (mapcar 'downcase wl-user-mail-address-list)
- (list (downcase
- (wl-address-header-extract-address
- wl-from))))))
(defsubst wl-address-header-extract-address (str)
"Extracts a real e-mail address from STR and return it.
e.g. \"m-sakura@ccs.mt.nec.co.jp (Mine Sakurai)\"
-> \"m-sakura@ccs.mt.nec.co.jp\"."
(cond ((string-match ".*<\\([^>]*\\)>" str) ; .* to extract last <>
- (wl-match-string 1 str))
- ((string-match "\\([^ \t\n]*@[^ \t\n]*\\)" str)
(wl-match-string 1 str))
- (t str)))
+ ((string-match "\\([^ \t\n]*@[^ \t\n]*\\)" str)
+ (wl-match-string 1 str))
+ (t str)))
(defsubst wl-address-header-extract-realname (str)
"Extracts a real name from STR and return it.
e.g. \"Mr. bar <hoge@foo.com>\"
-> \"Mr. bar\"."
(cond ((string-match "\\(.*[^ \t]\\)[ \t]*<[^>]*>" str)
- (wl-match-string 1 str))
- (t "")))
+ (wl-match-string 1 str))
+ (t "")))
+
+
+(defun wl-address-get-petname-1 (string)
+ (let ((address (downcase (wl-address-header-extract-address string))))
+ (elmo-get-hash-val address wl-address-petname-hash)))
+
+(defsubst wl-address-get-petname (string)
+ (or (wl-address-get-petname-1 string)
+ string))
+
+(defun wl-address-user-mail-address-p (address)
+ "Judge whether ADDRESS is user's or not."
+ (if wl-user-mail-address-regexp
+ (string-match wl-user-mail-address-regexp
+ (wl-address-header-extract-address address))
+ (member (downcase (wl-address-header-extract-address address))
+ (or (mapcar 'downcase wl-user-mail-address-list)
+ (list (downcase
+ (wl-address-header-extract-address
+ wl-from)))))))
+
+(defun wl-address-delete-user-mail-addresses (address-list)
+ "Delete user mail addresses from list by side effect.
+Deletion is done by using `elmo-list-delete'."
+ (if wl-user-mail-address-regexp
+ (elmo-list-delete (list wl-user-mail-address-regexp) address-list
+ (lambda (elem list)
+ (elmo-delete-if
+ (lambda (item) (string-match elem item))
+ list)))
+ (let ((myself (or wl-user-mail-address-list
+ (list (wl-address-header-extract-address wl-from)))))
+ (elmo-list-delete myself address-list
+ (lambda (elem list)
+ (elmo-delete-if
+ (lambda (item) (string= (downcase elem)
+ (downcase item)))
+ list))))))
(defmacro wl-address-concat-token (string token)
(` (cond
(with-temp-buffer
(message "Deleting Address...")
(insert-file-contents wl-address-file)
- (delete-matching-lines (concat "^[ \t]*" the-email))
+ (delete-matching-lines (concat "^[ \t]*" the-email "[ \t]+\".*\"[ \t]+\".*\"$"))
(write-region (point-min) (point-max)
wl-address-file nil 'no-msg)
;; Delete entries.
the-realname)))
(when change-address
(setq new-addr (read-from-minibuffer "E-Mail: " address))
- (if (and (not (string= address new-addr))
- (assoc new-addr wl-address-list))
- (error "'%s' already exists" new-addr)))
+ (cond
+ ((or (not (stringp new-addr))
+ (string-match "^[ \t]*$" new-addr))
+ (error "empty address"))
+ ((and (not (string= address new-addr))
+ (assoc new-addr wl-address-list))
+ (error "'%s' already exists" new-addr))
+ (t
+ ;; do nothing
+ )))
;; writing to ~/.address
(let ((output-coding-system
(mime-charset-to-coding-system wl-mime-charset)))
(wl-address-init)
(list (or new-addr address) the-petname the-realname)))))
+;; Read addresses from minibuffer with completion.
+(defvar wl-address-minibuffer-history nil)
+(defvar wl-address-minibuffer-local-map nil
+ "Keymap to use when reading address from the minibuffer.")
+
+(unless wl-address-minibuffer-local-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map minibuffer-local-map)
+ (define-key map "\C-i"
+ (lambda ()
+ (interactive)
+ (wl-complete-field-body wl-address-completion-list
+ ?@ nil wl-use-ldap)))
+ (setq wl-address-minibuffer-local-map map)))
+
+(defun wl-address-read-from-minibuffer (prompt &optional
+ initial-contents
+ default-value)
+ (read-from-minibuffer prompt
+ initial-contents
+ wl-address-minibuffer-local-map
+ nil
+ 'wl-address-minibuffer-history
+ default-value))
+
(require 'product)
(product-provide (provide 'wl-address) (require 'wl-version))