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