1;;; wl-address.el --- Tiny address management for Wanderlust.  -*- lexical-binding: t -*-
2
3;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
4;; Copyright (C) 1998,1999,2000 Shun-ichi GOTO <gotoh@taiyo.co.jp>
5;; Copyright (C) 1998,1999,2000 Takeshi Chiba <chiba@d3.bs1.fc.nec.co.jp>
6
7;; Author: Yuuichi Teranishi <teranisi@gohome.org>
8;;	Shun-ichi GOTO <gotoh@taiyo.co.jp>
9;;	Takeshi Chiba <chiba@d3.bs1.fc.nec.co.jp>
10;; Keywords: mail, net news
11
12;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
13
14;; This program is free software; you can redistribute it and/or modify
15;; it under the terms of the GNU General Public License as published by
16;; the Free Software Foundation; either version 2, or (at your option)
17;; any later version.
18;;
19;; This program is distributed in the hope that it will be useful,
20;; but WITHOUT ANY WARRANTY; without even the implied warranty of
21;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
22;; GNU General Public License for more details.
23;;
24;; You should have received a copy of the GNU General Public License
25;; along with GNU Emacs; see the file COPYING.  If not, write to the
26;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
27;; Boston, MA 02111-1307, USA.
28;;
29
30;;; Commentary:
31;;
32
33;;; Code:
34;;
35
36(require 'wl-util)
37(require 'wl-vars)
38(require 'std11)
39
40(defvar wl-address-complete-header-list
41  '("To:" "From:" "Cc:" "Bcc:" "Mail-Followup-To:" "Reply-To:"
42    "Return-Receipt-To:"))
43(defvar wl-address-complete-header-regexp nil) ; auto-generated.
44(defvar wl-newsgroups-complete-header-regexp "^\\(Newsgroups\\|Followup-To\\):")
45(defvar wl-folder-complete-header-regexp "^\\(Fcc\\):")
46(defvar wl-address-list nil)
47(defvar wl-address-completion-list nil)
48(defvar wl-address-petname-hash nil)
49(defvar wl-address-enable-strict-loading t)
50
51(defvar wl-address-ldap-search-hash nil)
52
53(eval-when-compile (require 'pldap))
54
55(defvar wl-ldap-alias-dn-level nil
56"Level of dn data to make alias postfix.
57Valid value is nit, t, 1 or larget integer.
58
59If this value nil, minimum alias postfix is made depends on uniqness
60with other candidates.  In this implementation, it's same to 1.  If t,
61always append all dn data.  If number, always append spcified level of
62data but maybe appended more uniqness.  If invalid value, treat as
63nil.
64
65For example, following dn data is exsist, alias of each level is shown
66bellow.
67
68Match: Goto
69dn: CN=Shun-ichi GOTO,OU=Mew,OU=Emacs,OU=Lisper,O=Programmers Inc.
70  nil => Goto/Shun-ichi_GOTO
71    1 => Goto/Shun-ichi_GOTO
72    2 => Goto/Shun-ichi_GOTO/Mew
73    3 => Goto/Shun-ichi_GOTO/Mew/Emacs
74    4 => Goto/Shun-ichi_GOTO/Mew/Emacs/Lisper
75    5 => Goto/Shun-ichi_GOTO/Mew/Emacs/Lisper/Programmers_Inc_
76    6 => Goto/Shun-ichi_GOTO/Mew/Emacs/Lisper/Programmers_Inc_
77    t => Goto/Shun-ichi_GOTO/Mew/Emacs/Lisper/Programmers_Inc_
78
79If level 3 is required for uniqness with other candidates,
80  nil => Goto/Shun-ichi_GOTO/Mew/Emacs    ... appended more
81    1 => Goto/Shun-ichi_GOTO/Mew/Emacs    ... appended more
82    2 => Goto/Shun-ichi_GOTO/Mew/Emacs    ... appended more
83    3 => Goto/Shun-ichi_GOTO/Mew/Emacs
84    4 => Goto/Shun-ichi_GOTO/Mew/Emacs/Lisper
85    (so on...)")
86
87(defconst wl-ldap-alias-sep "/")
88
89(defconst wl-ldap-search-attribute-type-list
90  '("sn" "cn" "mail" "email"))
91
92(defun wl-ldap-get-value (type entry)
93  ""
94  (let* ((values (cdr (assoc type entry)))
95	 (ret (car values)))
96    (if (and ret (not ldap-ignore-attribute-codings))
97	(while values
98	  (if (not (string-match "^[\000-\177]*$" (car values)))
99	      (setq ret (car values)
100		    values nil)
101	    (setq values (cdr values)))))
102    ret))
103
104(defun wl-ldap-get-value-list (type entry)
105  ""
106  (cdr (assoc type entry)))
107
108(defun wl-ldap-make-filter (pat type-list)
109  "Make RFC1558 quiery filter for PAT from ATTR-LIST.
110Each are \"OR\" combination, and PAT is beginning-match."
111  (concat "(|"
112	  (mapconcat (lambda (x) (format "(%s=%s*)" x pat)) ; fixed format
113		     type-list
114		     "")
115	  ")"))
116
117(defun wl-ldap-make-matched-value-list (regexp type-list entry)
118  "Correct matching WORD with value of TYPE-LIST in ENTRY.
119Returns matched uniq string list."
120  (let (type val values result)
121    ;; collect matching value
122    (while entry
123      (setq type (car (car entry))
124	    values (mapcar (function wl-ldap-alias-safe-string)
125			   (cdr (car entry)))
126	    values (elmo-flatten values)
127	    entry (cdr entry))
128      (if (member type type-list)
129	  (while values
130	    (setq val (car values)
131		  values (cdr values))
132	    (if (and (string-match regexp val)
133		     (not (member val result)))
134		(setq result (cons val result))))))
135    result))
136
137(defun wl-ldap-alias-safe-string (str)
138  "Modify STR for alias.
139Replace space/tab in STR into '_' char.
140Replace '@' in STR into list of mailbox and sub-domains."
141  (while (string-match "[ \t]+" str)
142    (setq str (concat (substring str 0 (match-beginning 0))
143		      "_"
144		      (substring str (match-end 0)))))
145  (if (string-match "\\(@\\)[^/@]+" str)
146      (setq str (split-string str  "[@\\.]")))
147  str)
148
149(defun wl-ldap-register-dn-string (hash dn &optional str dn-list)
150  ""
151  (let (sym dnsym value level)
152    (setq dnsym (intern (upcase dn) hash))
153    (if (and (null str) (boundp dnsym))
154	()					; already processed
155      ;; make dn-list in fisrt time
156      (if (null dn-list)
157	  (let ((case-fold-search t))
158	    (setq dn-list (mapcar (lambda (str)
159				    (if (string-match "[a-z]+=\\(.*\\)" str)
160					(wl-ldap-alias-safe-string
161					 (match-string 1 str))))
162				  (split-string dn "[ \t]*,[ \t]*")))))
163      (setq dn-list (elmo-flatten dn-list))
164      ;; prepare candidate for uniq str
165      (if str
166	  (setq str (concat str wl-ldap-alias-sep (car dn-list))
167		dn-list (cdr dn-list))
168	;; first entry, pre-build with given level
169	(cond
170	 ((null wl-ldap-alias-dn-level) (setq level 1))
171	 ((eq t wl-ldap-alias-dn-level) (setq level 1000)) ; xxx, big enough
172	 ((numberp wl-ldap-alias-dn-level)
173	  (if (< 0 wl-ldap-alias-dn-level)
174	      (setq level  wl-ldap-alias-dn-level)
175	    (setq level 1)))
176	 (t
177	  (setq level 1)))
178	(while (and (< 0 level) dn-list)
179	  (if (null str)
180	      (setq str (car dn-list))
181	    (setq str (concat str wl-ldap-alias-sep (car dn-list))))
182	  (setq level (1- level)
183		dn-list (cdr dn-list))))
184      (setq sym (intern (upcase str) hash))
185      (if (not (boundp sym))
186	  ;; good
187	  (progn (set sym (list dn str dn-list))
188		 (set dnsym str))
189	;; conflict
190	(if (not (eq (setq value (symbol-value sym)) t))
191	    ;; move away deeper
192	    (progn (set sym t)
193		   (apply (function wl-ldap-register-dn-string) hash value)))
194	(wl-ldap-register-dn-string hash dn str dn-list)))))
195
196(declare-function ldap-search-entries "pldap"
197		  (filter &optional host attributes attrsonly withdn))
198
199(defun wl-address-ldap-search (pattern cl)
200  "Make address completion-list matched for PATTERN by LDAP search.
201Matched address lists are append to CL."
202  (require 'pldap)
203  (unless wl-address-ldap-search-hash
204    (setq wl-address-ldap-search-hash (elmo-make-hash 7)))
205  (let ((pat (if (string-match wl-ldap-alias-sep pattern)
206		 (substring pattern 0 (match-beginning 0))
207	       pattern))
208	(ldap-default-host (or wl-ldap-server ldap-default-host "localhost"))
209	(ldap-default-port (or wl-ldap-port ldap-default-port 389))
210	(ldap-default-base (or wl-ldap-base ldap-default-base))
211	(dnhash (elmo-make-hash))
212	cache len sym tmpl regexp entries ent values dn dnstr alias
213	result cn mails)
214    ;; check cache
215    (mapatoms (lambda (atom)
216		(if (and (string-match
217			  (concat "^" (symbol-name atom) ".*") pat)
218			 (or (null cache)
219			     (< (car cache)
220				(setq len (length (symbol-name atom))))))
221		    (setq cache (cons
222				 (or len (length (symbol-name atom)))
223				 (symbol-value atom)))))
224	      wl-address-ldap-search-hash)
225    ;; get matched entries
226    (if cache
227	(setq entries (cdr cache))
228      (ignore-errors
229	(message "Searching in LDAP...")
230	(setq entries (ldap-search-entries
231		       (wl-ldap-make-filter
232			pat wl-ldap-search-attribute-type-list)
233		       nil wl-ldap-search-attribute-type-list nil t))
234	(message "Searching in LDAP...done")
235	(elmo-set-hash-val pattern entries wl-address-ldap-search-hash)))
236    ;;
237    (setq tmpl entries)
238    (while tmpl
239      (wl-ldap-register-dn-string dnhash (car (car tmpl))) ; car is 'dn'.
240      (setq tmpl (cdr tmpl)))
241    ;;
242    (setq regexp (concat "^" pat))
243    (while entries
244      (setq ent (cdar entries)
245	    values (wl-ldap-make-matched-value-list
246		    regexp wl-ldap-search-attribute-type-list
247		    ent)
248	    mails (or (wl-ldap-get-value-list "mail" ent)
249		      (wl-ldap-get-value-list "email" ent))
250	    cn (wl-ldap-get-value "cn" ent)
251	    dn (car (car entries))
252	    dnstr (elmo-get-hash-val (upcase dn) dnhash))
253      ;; make alias list generated from LDAP data.
254      (while (and mails values)
255	;; make alias like MATCHED/DN-STRING
256	(if (not (string-match (concat "^" (regexp-quote (car values))) dnstr))
257	    (setq alias (concat (car values) wl-ldap-alias-sep dnstr))
258	  ;; use DN-STRING if DN-STRING begin with MATCHED
259	  (setq alias dnstr))
260	;; check uniqness then add to list
261	(setq sym (intern (downcase alias) dnhash))
262	(when (not (boundp sym))
263	  (set sym alias)
264	  (setq result (cons (cons alias
265				   (concat cn " <" (car mails) ">"))
266			     result)))
267	(setq values (cdr values)))
268      ;; make mail addrses list
269      (while mails
270	(if (null (assoc (car mails) cl)); Not already in cl.
271;;;	    (string-match regexp (car mails))
272	    ;; add mail address itself to completion list
273	    (setq result (cons (cons (car mails)
274				     (concat cn " <" (car mails) ">"))
275			       result)))
276	(setq mails (cdr mails)))
277      (setq entries (cdr entries)))
278    (append result cl)))
279
280(defun wl-complete-address (string predicate flag)
281  "Completion function for completing-read (comma separated addresses)."
282  (if (string-match "^\\(.*,\\)\\(.*\\)$" string)
283      (let* ((str1 (match-string 1 string))
284	     (str2 (match-string 2 string))
285	     (str2-comp (wl-complete-address str2 predicate flag)))
286	(if (and (not flag) (stringp str2-comp))
287	    (concat str1 str2-comp)
288	  str2-comp))
289    (if (not flag)
290	(try-completion string wl-address-list)
291      (all-completions string wl-address-list))))
292
293(defalias 'wl-address-quote-specials 'elmo-address-quote-specials)
294(make-obsolete 'wl-address-quote-specials 'elmo-address-quote-specials
295	       "20 Sep 2001")
296
297(defun wl-address-make-completion-list (address-list)
298  (let (addr-tuple cl)
299    (while address-list
300      (setq addr-tuple (car address-list))
301      (setq cl
302	    (cons
303	     (wl-address-make-completion-entry 0 addr-tuple)
304	     cl))
305      ;; nickname completion.
306      (if wl-address-enable-strict-loading
307	  (unless (or (equal (nth 1 addr-tuple) (nth 0 addr-tuple))
308		      ;; already exists
309		      (assoc (nth 1 addr-tuple) cl))
310	    (setq cl
311		  (cons
312		   (wl-address-make-completion-entry 1 addr-tuple)
313		   cl)))
314	(setq cl
315	      (cons
316	       (wl-address-make-completion-entry 1 addr-tuple)
317	       cl)))
318      (setq address-list (cdr address-list)))
319    cl))
320
321(defun wl-address-make-completion-entry (index addr-tuple)
322  (cons (nth index addr-tuple)
323	(if (or (string= (nth 2 addr-tuple) "")
324		(string-match ".*:.*;$" (nth 0 addr-tuple)))
325	    (nth 0 addr-tuple)
326	  (concat
327	   (elmo-address-quote-specials
328	    (nth 2 addr-tuple)) " <"(nth 0 addr-tuple)">"))))
329
330(defun wl-complete-field-body-or-tab ()
331  (interactive)
332  (let ((case-fold-search t)
333	epand-char skip-chars
334	(use-ldap nil)
335	completion-list)
336    (if (wl-draft-on-field-p)
337	(wl-complete-field)
338      (if (and
339	   (< (point)
340	      (save-excursion
341		(goto-char (point-min))
342		(search-forward (concat "\n" mail-header-separator "\n") nil 0)
343		(point)))
344	   (save-excursion
345	     (beginning-of-line)
346	     (setq use-ldap nil)
347	     (while (and (looking-at "^[ \t]")
348			 (not (= (point) (point-min))))
349	       (forward-line -1))
350	     (cond ((looking-at wl-address-complete-header-regexp)
351		    (setq completion-list wl-address-completion-list)
352		    (if wl-use-ldap
353			(setq use-ldap t))
354		    (setq epand-char ?@))
355		   ((looking-at wl-folder-complete-header-regexp)
356		    (setq completion-list wl-folder-entity-hashtb)
357		    (setq skip-chars "^, "))
358		   ((looking-at wl-newsgroups-complete-header-regexp)
359		    (setq completion-list wl-folder-newsgroups-hashtb)))))
360	  (wl-complete-field-body completion-list
361				  epand-char skip-chars use-ldap)
362	(indent-for-tab-command)))))
363
364(defvar wl-completion-buf-name "*Completions*")
365
366(defvar wl-complete-candidates nil)
367
368(defun wl-complete-window-show (all)
369  (if (and (get-buffer-window wl-completion-buf-name)
370	   (equal wl-complete-candidates all))
371      (let ((win (get-buffer-window wl-completion-buf-name)))
372	(with-current-buffer wl-completion-buf-name
373	  (if (pos-visible-in-window-p (point-max) win)
374	      (set-window-start win 1)
375	    (scroll-other-window))))
376    (message "Making completion list...")
377    (setq wl-complete-candidates all)
378    (with-output-to-temp-buffer
379	wl-completion-buf-name
380      (display-completion-list all))
381    (message "Making completion list...done")))
382
383(defun wl-complete-window-delete ()
384  (let (comp-buf comp-win)
385    (when (and (setq comp-buf (get-buffer wl-completion-buf-name))
386	       (setq comp-win (get-buffer-window comp-buf)))
387      (delete-window comp-win))))
388
389(defun wl-complete-field ()
390  (interactive)
391  (let* ((end (point))
392	 (start (save-excursion
393		  (skip-chars-backward "_a-zA-Z0-9+@%.!\\-")
394		  (point)))
395	 (completion)
396	 (pattern (buffer-substring start end))
397	 (cl wl-draft-field-completion-list))
398    (if (null cl)
399	nil
400      (setq completion
401	    (let ((completion-ignore-case t))
402	      (try-completion pattern cl)))
403      (cond ((eq completion t)
404	     (let ((alias (assoc pattern cl)))
405	       (if alias
406		   (progn
407		     (delete-region start end)
408		     (insert (cdr alias))
409;;;		     (wl-highlight-message (point-min)(point-max) t)
410		     )))
411	     (wl-complete-window-delete))
412	    ((null completion)
413	     (message "Can't find completion for \"%s\"" pattern)
414	     (ding))
415	    ((not (string= pattern completion))
416	     (delete-region start end)
417	     (insert completion)
418	     (wl-complete-window-delete)
419	     (wl-highlight-message (point-min)(point-max) t))
420	    (t
421	     (let ((list (all-completions pattern cl)))
422	       (wl-complete-window-show list)))))))
423
424(defun wl-complete-insert (start end pattern completion-list)
425  (let ((alias (and (consp completion-list)
426		    (assoc pattern completion-list)))
427	comp-buf comp-win)
428    (if alias
429	(progn
430	  (delete-region start end)
431	  (insert (cdr alias))
432	  (if (setq comp-buf (get-buffer wl-completion-buf-name))
433	      (if (setq comp-win (get-buffer-window comp-buf))
434		  (delete-window comp-win)))))))
435
436(defun wl-complete-field-body (completion-list
437			       &optional epand-char skip-chars use-ldap)
438  (interactive)
439  (let* ((end (point))
440	 (start (save-excursion
441		  (skip-chars-backward (or skip-chars "^:,>\n"))
442		  (skip-chars-forward " \t")
443		  (point)))
444	 (completion)
445	 (pattern (buffer-substring start end))
446	 (len (length pattern))
447	 (completion-ignore-case t)
448	 (cl completion-list))
449    (when use-ldap
450      (setq cl (wl-address-ldap-search pattern cl)))
451    (if (null cl)
452	nil
453      (setq completion (try-completion pattern cl))
454      (cond ((eq completion t)
455	     (if use-ldap (setq wl-address-ldap-search-hash nil))
456	     (wl-complete-insert start end pattern cl)
457	     (wl-complete-window-delete)
458	     (message "Sole completion"))
459	    ((and epand-char
460		  (> len 0)
461		  (or (char-equal (aref pattern (1- len)) epand-char)
462		      (char-equal (aref pattern (1- len)) (string-to-char " ")))
463		  (assoc (substring pattern 0 (1- len)) cl))
464	     (wl-complete-insert
465	      start end
466	      (substring pattern 0 (1- len))
467	      cl))
468	    ((null completion)
469	     (message "Can't find completion for \"%s\"" pattern)
470	     (ding))
471	    ((not (string= pattern completion))
472	     (delete-region start end)
473	     (insert completion))
474	    (t
475	     (let ((list (sort (all-completions pattern cl) 'string<)))
476	       (wl-complete-window-show list)))))))
477
478(defvar wl-address-init-function 'wl-local-address-init)
479
480(defun wl-address-init ()
481  "Call `wl-address-init-function'."
482  (funcall wl-address-init-function))
483
484(defun wl-local-address-init ()
485  "Reload `wl-address-file'.
486Refresh `wl-address-list', `wl-address-completion-list', and
487`wl-address-petname-hash'."
488  (message "Updating addresses...")
489  (setq wl-address-list
490	(wl-address-make-address-list wl-address-file))
491  (setq wl-address-completion-list
492	(wl-address-make-completion-list wl-address-list))
493  (if (file-readable-p wl-alias-file)
494      (setq wl-address-completion-list
495	    (append wl-address-completion-list
496		    (wl-address-make-alist-from-alias-file wl-alias-file))))
497  (setq wl-address-petname-hash (elmo-make-hash))
498  (let ((addresses wl-address-list))
499    (while addresses
500      (elmo-set-hash-val (downcase (car (car addresses)))
501			 (cadr (car addresses))
502			 wl-address-petname-hash)
503      (setq addresses (cdr addresses))))
504  (message "Updating addresses...done"))
505
506
507(defun wl-address-expand-aliases (alist nest-count)
508  (when (< nest-count 5)
509    (let (expn-str new-expn-str expn new-expn(n 0) (expanded nil))
510      (while (setq expn-str (cdr (nth n alist)))
511	(setq new-expn-str nil)
512	(while (string-match "^[ \t]*\\([^,]+\\)" expn-str)
513	  (setq expn (match-string 1 expn-str))
514	  (setq expn-str (elmo-string-delete-match expn-str 0))
515	  (if (string-match "^[ \t,]+" expn-str)
516	      (setq expn-str (elmo-string-delete-match expn-str 0)))
517	  (if (string-match "[ \t,]+$" expn)
518	      (setq expn (elmo-string-delete-match expn 0)))
519	  (setq new-expn (cdr (assoc expn alist)))
520	  (if new-expn
521	      (setq expanded t))
522	  (setq new-expn-str (concat new-expn-str (and new-expn-str ", ")
523				     (or new-expn expn))))
524	(when new-expn-str
525	  (setcdr (nth n alist) new-expn-str))
526	(setq n (1+ n)))
527      (and expanded
528	   (wl-address-expand-aliases alist (1+ nest-count))))))
529
530(defun wl-address-make-alist-from-alias-file (file)
531  (with-temp-buffer
532    (let ((case-fold-search t)
533	  alias expn alist)
534      (insert-file-contents file)
535      (while (re-search-forward ",$" nil t)
536	(end-of-line)
537	(forward-char)
538	(delete-char -1))
539      (goto-char (point-min))
540      (while (re-search-forward "^\\([^#;\n][^:]+\\):[ \t]*\\(.*\\)$" nil t)
541	(setq alias (match-string-no-properties 1)
542	      expn (match-string-no-properties 2))
543	(setq alist (cons (cons alias expn) alist)))
544      (wl-address-expand-aliases alist 0)
545      (nreverse alist) ; return value
546      )))
547
548(defun wl-address-make-address-list (path)
549  (when (and path (file-readable-p path))
550    (with-temp-buffer
551      (let (ret
552	    (coding-system-for-read 'undecided))
553	(insert-file-contents path)
554	(goto-char (point-min))
555	(while (not (eobp))
556	  (if (looking-at "\
557^\\([^#\n][^ \t\n]+\\)[ \t]+\\(\".*\"\\)[ \t]+\\(\".*\"\\)[ \t]*.*$")
558	      (setq ret
559		    (cons
560		     (list (match-string-no-properties 1)
561			   (read (match-string-no-properties 2))
562			   (read (match-string-no-properties 3)))
563		     ret)))
564	  (forward-line))
565	(nreverse ret)))))
566
567
568(defsubst wl-address-header-extract-address (str)
569  "Extracts a real e-mail address from STR and return it.
570e.g. \"Mine Sakurai <m-sakura@example.org>\"
571  ->  \"m-sakura@example.org\".
572e.g. \"m-sakura@example.org (Mine Sakurai)\"
573  ->  \"m-sakura@example.org\"."
574  (cond ((string-match ".*<\\([^>]*\\)>" str) ; .* to extract last <>
575	 (match-string 1 str))
576	((string-match "\\([^ \t\n]*@[^ \t\n]*\\)" str)
577	 (match-string 1 str))
578	(t str)))
579
580(defsubst wl-address-header-extract-realname (str)
581  "Extracts a real name from STR and return it.
582e.g. \"Mr. bar <hoge@example.com>\"
583  ->  \"Mr. bar\"."
584  (cond ((string-match "\\(.*[^ \t]\\)[ \t]*<[^>]*>" str)
585	 (match-string 1 str))
586	(t "")))
587
588
589(defun wl-address-get-petname-1 (string)
590  (let ((address (downcase (wl-address-header-extract-address string))))
591    (elmo-get-hash-val address wl-address-petname-hash)))
592
593(defsubst wl-address-get-petname (string)
594  (or (wl-address-get-petname-1 string)
595      string))
596
597(defun wl-address-user-mail-address-p (address)
598  "Judge whether ADDRESS is user's or not."
599  (if wl-user-mail-address-regexp
600      (string-match wl-user-mail-address-regexp
601		    (wl-address-header-extract-address address))
602    (member (downcase (wl-address-header-extract-address address))
603	    (or (mapcar 'downcase wl-user-mail-address-list)
604		(list (downcase
605		       (wl-address-header-extract-address
606			wl-from)))))))
607
608(defun wl-address-delete-user-mail-addresses (address-list)
609  "Delete user mail addresses from list by side effect.
610Deletion is done by using `elmo-list-delete'."
611  (if wl-user-mail-address-regexp
612      (elmo-list-delete (list wl-user-mail-address-regexp) address-list
613			(lambda (elem list)
614			  (elmo-delete-if
615			   (lambda (item) (string-match elem item))
616			   list)))
617    (let ((myself (or wl-user-mail-address-list
618		      (list (wl-address-header-extract-address wl-from)))))
619      (elmo-list-delete myself address-list
620			(lambda (elem list)
621			  (elmo-delete-if
622			   (lambda (item) (string= (downcase elem)
623						   (downcase item)))
624			   list))))))
625
626(defmacro wl-address-concat-token (string token)
627  `(cond
628    ((eq 'quoted-string (car ,token))
629     (concat ,string "\"" (cdr ,token) "\""))
630    ((eq 'comment (car ,token))
631     (concat ,string "(" (cdr ,token) ")"))
632    (t
633     (concat ,string (cdr ,token)))))
634
635(defun wl-address-string-without-group-list-contents (sequence)
636  "Return address string from lexical analyzed list SEQUENCE.
637Group list contents is not included."
638  (let (address-string route-addr-end token seq group-end)
639  (while sequence
640    (setq token (car sequence))
641    (cond
642     ;;   group       =  phrase ":" [#mailbox] ";"
643     ((and (eq 'specials (car token))
644	   (string= (cdr token) ":"))
645      (setq address-string (concat address-string (cdr token))) ; ':'
646      (setq seq (cdr sequence))
647      (setq token (car seq))
648      (setq group-end nil)
649      (while (not group-end)
650	(setq token (car seq))
651	(setq seq (cdr seq))
652	(setq group-end (and (eq 'specials (car token))
653			     (string= (cdr token) ";"))))
654      (setq address-string (concat address-string (cdr token))) ; ';'
655      (setq sequence seq))
656     ;;   route-addr  =  "<" [route] addr-spec ">"
657     ;;   route       =  1#("@" domain) ":"           ; path-relative
658     ((and (eq 'specials (car token))
659	   (string= (cdr token) "<"))
660      (setq seq (std11-parse-route-addr sequence))
661      (setq route-addr-end (car (cdr seq)))
662      (while (not (eq (car sequence) route-addr-end))
663	(setq address-string (wl-address-concat-token address-string
664						      (car sequence)))
665	(setq sequence (cdr sequence))))
666     (t
667      (setq address-string (wl-address-concat-token address-string token))
668      (setq sequence (cdr sequence)))))
669  address-string))
670
671(defun wl-address-delete (the-email)
672  "Delete address entry in the `wl-address-file'."
673  (with-temp-buffer
674    (message "Deleting Address...")
675    (insert-file-contents wl-address-file)
676    (delete-matching-lines (concat "^[ \t]*" the-email "[ \t]+\".*\"[ \t]+\".*\"$"))
677    (write-region (point-min) (point-max)
678		  wl-address-file nil 'no-msg)
679    ;; Delete entries.
680    (dolist (entry (elmo-string-assoc-all the-email wl-address-list))
681      (setq wl-address-list (delete entry wl-address-list)))
682    (elmo-set-hash-val the-email nil wl-address-petname-hash)
683    (message "Deleting Address...done")))
684
685(defun wl-address-add-or-change (address
686				 &optional default-realname
687				 change-address)
688  "Add address entry to `wl-address-file', if not registerd.
689If already registerd, change it."
690  (let ((entry (assoc address wl-address-list))
691	the-realname the-petname new-addr regexp)
692    (setq the-realname
693	  (read-from-minibuffer "Real Name: " (or default-realname
694						  (nth 2 entry))))
695    (setq the-petname (read-from-minibuffer "Petname: "
696					    (or (nth 1 entry)
697						the-realname)))
698    (when change-address
699      (setq new-addr (read-from-minibuffer "E-Mail: " address))
700      (cond
701       ((or (not (stringp new-addr))
702	    (string-match "^[ \t]*$" new-addr))
703	(error "empty address"))
704       ((and (not (string= address new-addr))
705	     (assoc new-addr wl-address-list))
706	(error "'%s' already exists" new-addr))
707       (t
708	;; do nothing
709	)))
710    ;; writing to ~/.address
711    (with-temp-buffer
712      (if (file-exists-p wl-address-file)
713	  (insert-file-contents wl-address-file))
714      (if (null entry)
715	  ;; add
716	  (progn
717	    (goto-char (point-max))
718	    (if (and (> (buffer-size) 0)
719		     (/= (char-before (point-max)) ?\n))
720		(insert "\n")))
721	;; override
722	(setq regexp (concat "^[ \t]*" address))
723	(while (re-search-forward regexp  nil t)
724	  (delete-region (point-at-bol) (1+ (point-at-eol)))))
725      (insert (format "%s\t%s\t%s\n"
726		      (or new-addr address)
727		      (prin1-to-string the-petname)
728		      (prin1-to-string the-realname)))
729      (write-region (point-min) (point-max)
730		    wl-address-file nil 'no-msg)
731      (wl-address-init)
732      (list (or new-addr address) the-petname the-realname))))
733
734;; Read addresses from minibuffer with completion.
735(defvar wl-address-minibuffer-history nil)
736(defvar wl-address-minibuffer-local-map nil
737  "Keymap to use when reading address from the minibuffer.")
738
739(unless wl-address-minibuffer-local-map
740  (let ((map (make-sparse-keymap)))
741    (set-keymap-parent map minibuffer-local-map)
742    (define-key map "\C-i"
743      (lambda ()
744	(interactive)
745	(wl-complete-field-body wl-address-completion-list
746				?@ nil wl-use-ldap)))
747    (setq wl-address-minibuffer-local-map map)))
748
749(defun wl-address-read-from-minibuffer (prompt &optional
750					       initial-contents
751					       default-value)
752  (read-from-minibuffer prompt
753			initial-contents
754			wl-address-minibuffer-local-map
755			nil
756			'wl-address-minibuffer-history
757			default-value))
758
759(require 'product)
760(product-provide (provide 'wl-address) (require 'wl-version))
761
762;;; wl-address.el ends here
763
764