wl/wl-address.el

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