X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=wl%2Fwl-address.el;h=d539d6b09acff68bd4889c6901f849a473c5acb4;hb=57f081e684a5f0a1de02c96bc61ec175784974bb;hp=13751c6fede2e5ed2049914f9bce459091766285;hpb=f3d35a20272dce997e602909c9ab8f87f576dfeb;p=elisp%2Fwanderlust.git

diff --git a/wl/wl-address.el b/wl/wl-address.el
index 13751c6..d539d6b 100644
--- a/wl/wl-address.el
+++ b/wl/wl-address.el
@@ -37,12 +37,16 @@
 (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)
 
@@ -83,7 +87,7 @@ If level 3 is required for uniqness with other candidates,
 (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)
   ""
@@ -104,11 +108,11 @@ If level 3 is required for uniqness with other candidates,
 (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.
@@ -121,8 +125,6 @@ Returns matched uniq string list."
 			   (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)
@@ -136,7 +138,7 @@ Returns matched uniq string list."
   "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)))))
@@ -200,9 +202,9 @@ Matched address lists are append to CL."
   (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)
@@ -220,17 +222,14 @@ Matched address lists are append to CL."
     ;; 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
@@ -241,8 +240,10 @@ Matched address lists are append to CL."
     (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))
@@ -273,12 +274,18 @@ Matched address lists are append to CL."
       (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-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)
 
@@ -288,31 +295,33 @@ Matched address lists are append to CL."
       (setq addr-tuple (car address-list))
       (setq cl
 	    (cons
-	     (cons (nth 0 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)">")))
+	     (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)
-		     (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)">")))
+	       (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)
@@ -365,7 +374,7 @@ Matched address lists are append to CL."
     (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)
@@ -431,6 +440,7 @@ Matched address lists are append to CL."
 	 (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)))
@@ -444,7 +454,8 @@ Matched address lists are append to 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
@@ -541,29 +552,14 @@ Refresh `wl-address-list', `wl-address-completion-list', and
 	   (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))))
-
-(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)))
+	 (nreverse ret)))))
 
-(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.
@@ -585,6 +581,44 @@ e.g. \"Mr. bar <hoge@foo.com>\"
 	 (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
       ((eq 'quoted-string (car (, token)))
@@ -637,7 +671,7 @@ Group list contents is not included."
     (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.
@@ -661,9 +695,16 @@ If already registerd, change it."
 						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)))
@@ -692,6 +733,31 @@ If already registerd, change it."
 	(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))