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 'std11)
  34
  35 (defvar wl-address-complete-header-regexp "^\\(To\\|From\\|Cc\\|Bcc\\|Mail-Followup-To\\|Reply-To\\|Return-Receipt-To\\):")
  36 (defvar wl-newsgroups-complete-header-regexp "^\\(Newsgroups\\|Followup-To\\):")
  37 (defvar wl-folder-complete-header-regexp "^\\(FCC\\):")
  38 (defvar wl-address-list nil)
  39 (defvar wl-address-completion-list nil)
  40 (defvar wl-address-petname-hash nil)
  41
  42 (defun wl-complete-field-to ()
  43   (interactive)
  44   (let ((cl wl-address-completion-list))
  45     (if cl
  46         (completing-read "To: " cl)
  47       (read-string "To: "))))
  48
  49 (defun wl-complete-field-body-or-tab ()
  50   (interactive)
  51   (let ((case-fold-search t)
  52         epand-char skip-chars
  53         completion-list)
  54     (if (wl-draft-on-field-p)
  55         (wl-complete-field)
  56       (if (and
  57            (< (point)
  58               (save-excursion
  59                 (goto-char (point-min))
  60                 (search-forward (concat "\n" mail-header-separator "\n") nil 0)
  61                 (point)))
  62            (save-excursion
  63              (beginning-of-line)
  64              (while (and (looking-at "^[ \t]")
  65                          (not (= (point) (point-min))))
  66                (forward-line -1))
  67              (cond ((looking-at wl-address-complete-header-regexp)
  68                     (setq completion-list wl-address-completion-list)
  69                     (setq epand-char ?@))
  70                    ((looking-at wl-folder-complete-header-regexp)
  71                     (setq completion-list wl-folder-entity-hashtb)
  72                     (setq skip-chars "^, "))
  73                    ((looking-at wl-newsgroups-complete-header-regexp)
  74                     (setq completion-list wl-folder-newsgroups-hashtb)))))
  75           (wl-complete-field-body completion-list
  76                                   epand-char skip-chars)
  77         (indent-for-tab-command)))))
  78
  79 (defvar wl-completion-buf-name "*Completions*")
  80
  81 (defvar wl-complete-candidates nil)
  82
  83 (defun wl-complete-window-show (all)
  84   (if (and (get-buffer-window wl-completion-buf-name)
  85            (equal wl-complete-candidates all))
  86       (let ((win (get-buffer-window wl-completion-buf-name)))
  87         (save-excursion
  88           (set-buffer wl-completion-buf-name)
  89           (if (pos-visible-in-window-p (point-max) win)
  90               (set-window-start win 1)
  91             (scroll-other-window))))
  92     (message "Making completion list...")
  93     (setq wl-complete-candidates all)
  94     (with-output-to-temp-buffer
  95         wl-completion-buf-name
  96       (display-completion-list all))
  97     (message "Making completion list... done")))
  98
  99 (defun wl-complete-window-delete ()
 100   (let (comp-buf comp-win)
 101     (if (setq comp-buf (get-buffer wl-completion-buf-name))
 102         (if (setq comp-win (get-buffer-window comp-buf))
 103             (delete-window comp-win)))))
 104
 105 (defun wl-complete-field ()
 106   (interactive)
 107   (let* ((end (point))
 108          (start (save-excursion
 109                   (skip-chars-backward "_a-zA-Z0-9+@%.!\\-")
 110                   (point)))
 111          (completion)
 112          (pattern (buffer-substring start end))
 113          (cl wl-draft-field-completion-list))
 114     (if (null cl)
 115         nil
 116       (setq completion
 117             (let ((completion-ignore-case t))
 118               (try-completion pattern cl)))
 119       (cond ((eq completion t)
 120              (let ((alias (assoc pattern cl)))
 121                (if alias
 122                    (progn
 123                      (delete-region start end)
 124                      (insert (cdr alias))
 125                 ;     (wl-highlight-message (point-min)(point-max) t)
 126                      )))
 127              (wl-complete-window-delete))
 128             ((null completion)
 129              (message "Can't find completion for \"%s\"" pattern)
 130              (ding))
 131             ((not (string= pattern completion))
 132              (delete-region start end)
 133              (insert completion)
 134              (wl-complete-window-delete)
 135              (wl-highlight-message (point-min)(point-max) t))
 136             (t
 137              (let ((list (all-completions pattern cl)))
 138                (wl-complete-window-show list)))))))
 139
 140 (defun wl-complete-insert (start end pattern completion-list)
 141   (let ((alias (and (consp completion-list)
 142                     (assoc pattern completion-list)))
 143         comp-buf comp-win)
 144     (if alias
 145         (progn
 146           (delete-region start end)
 147           (insert (cdr alias))
 148           (if (setq comp-buf (get-buffer wl-completion-buf-name))
 149               (if (setq comp-win (get-buffer-window comp-buf))
 150                   (delete-window comp-win)))))))
 151
 152 (defun wl-complete-field-body (completion-list &optional epand-char skip-chars)
 153   (interactive)
 154   (let* ((end (point))
 155          (start (save-excursion
 156 ;                 (skip-chars-backward "_a-zA-Z0-9+@%.!\\-")
 157                   (skip-chars-backward (or skip-chars
 158                                            "_a-zA-Z0-9+@%.!\\-/"))
 159                   (point)))
 160          (completion)
 161          (pattern (buffer-substring start end))
 162          (len (length pattern))
 163          (cl completion-list))
 164     (if (null cl)
 165         nil
 166       (setq completion (try-completion pattern cl))
 167       (cond ((eq completion t)
 168              (wl-complete-insert start end pattern completion-list)
 169              (wl-complete-window-delete)
 170              (message "Sole completion"))
 171             ((and epand-char
 172                   (> len 0)
 173                   (char-equal (aref pattern (1- len)) epand-char)
 174                   (assoc (substring pattern 0 (1- len)) cl))
 175              (wl-complete-insert
 176               start end
 177               (substring pattern 0 (1- len))
 178               cl))
 179             ((null completion)
 180              (message "Can't find completion for \"%s\"" pattern)
 181              (ding))
 182             ((not (string= pattern completion))
 183              (delete-region start end)
 184              (insert completion))
 185             (t
 186              (let ((list (sort (all-completions pattern cl) 'string<)))
 187                (wl-complete-window-show list)))))))
 188
 189 (defvar wl-address-init-func 'wl-local-address-init)
 190
 191 (defun wl-address-init ()
 192   (funcall wl-address-init-func))
 193
 194 (defun wl-local-address-init ()
 195   (message "Updating addresses...")
 196   (setq wl-address-list
 197         (wl-address-make-address-list wl-address-file))
 198   (setq wl-address-completion-list
 199         (wl-address-make-completion-list wl-address-list))
 200   (if (file-readable-p wl-alias-file)
 201       (setq wl-address-completion-list
 202             (append wl-address-completion-list
 203                     (wl-address-make-alist-from-alias-file wl-alias-file))))
 204   (setq wl-address-petname-hash (elmo-make-hash))
 205   (mapcar
 206    (function
 207         (lambda (x)
 208           (elmo-set-hash-val (downcase (car x))
 209                                                  (cadr x)
 210                                                  wl-address-petname-hash)))
 211    wl-address-list)
 212   (message "Updating addresses...done."))
 213
 214
 215 (defun wl-address-expand-aliases (alist nest-count)
 216   (when (< nest-count 5)
 217     (let (expn-str new-expn-str expn new-expn(n 0) (expanded nil))
 218       (while (setq expn-str (cdr (nth n alist)))
 219         (setq new-expn-str nil)
 220         (while (string-match "^[ \t]*\\([^,]+\\)" expn-str)
 221           (setq expn (elmo-match-string 1 expn-str))
 222           (setq expn-str (wl-string-delete-match expn-str 0))
 223           (if (string-match "^[ \t,]+" expn-str)
 224               (setq expn-str (wl-string-delete-match expn-str 0)))
 225           (if (string-match "[ \t,]+$" expn)
 226               (setq expn (wl-string-delete-match expn 0)))
 227           (setq new-expn (cdr (assoc expn alist)))
 228           (if new-expn
 229               (setq expanded t))
 230           (setq new-expn-str (concat new-expn-str (and new-expn-str ", ")
 231                                      (or new-expn expn))))
 232         (when new-expn-str
 233           (setcdr (nth n alist) new-expn-str))
 234         (setq n (1+ n)))
 235       (and expanded
 236            (wl-address-expand-aliases alist (1+ nest-count))))))
 237
 238 (defun wl-address-make-alist-from-alias-file (file)
 239   (elmo-set-work-buf
 240     (let ((case-fold-search t)
 241           alias expn alist)
 242       (insert-file-contents file)
 243       (while (re-search-forward ",$" nil t)
 244         (end-of-line)
 245         (forward-char 1)
 246         (delete-backward-char 1))
 247       (goto-char (point-min))
 248       (while (re-search-forward "^\\([^#;\n][^:]+\\):[ \t]*\\(.*\\)$" nil t)
 249         (setq alias (wl-match-buffer 1)
 250               expn (wl-match-buffer 2))
 251         (setq alist (cons (cons alias expn) alist)))
 252       (wl-address-expand-aliases alist 0)
 253       (nreverse alist) ; return value
 254       )))
 255
 256 (defun wl-address-make-address-list (path)
 257   (if (and path (file-readable-p path))
 258       (elmo-set-work-buf
 259         (let (ret
 260               (coding-system-for-read wl-cs-autoconv))
 261           (insert-file-contents path)
 262           (goto-char (point-min))
 263           (while (not (eobp))
 264             (if (looking-at
 265  "^\\([^#\n][^ \t\n]+\\)[ \t]+\"\\(.*\\)\"[ \t]+\"\\(.*\\)\"[ \t]*.*$")
 266                 (setq ret
 267                       (wl-append-element
 268                        ret
 269                        (list (wl-match-buffer 1)
 270                              (wl-match-buffer 2)
 271                              (wl-match-buffer 3)))))
 272             (forward-line))
 273           ret))))
 274
 275 (defsubst wl-address-get-petname (str)
 276   (let ((addr (downcase (wl-address-header-extract-address str))))
 277     (or (elmo-get-hash-val addr wl-address-petname-hash)
 278         str)))
 279
 280 (defsubst wl-address-make-completion-list (address-list)
 281   (mapcar '(lambda (entity)
 282              (cons (nth 0 entity)
 283                    (concat (nth 2 entity) " <"(nth 0 entity)">"))) address-list))
 284
 285 (defsubst wl-address-user-mail-address-p (address)
 286   "Judge whether ADDRESS is user's or not."
 287   (member (downcase (wl-address-header-extract-address address))
 288           (or (mapcar 'downcase wl-user-mail-address-list)
 289               (list (downcase
 290                      (wl-address-header-extract-address
 291                       wl-from))))))
 292
 293 (defsubst wl-address-header-extract-address (str)
 294   "Extracts a real e-mail address from STR and returns it.
 295 e.g. \"Mine Sakurai <m-sakura@ccs.mt.nec.co.jp>\"
 296   ->  \"m-sakura@ccs.mt.nec.co.jp\".
 297 e.g. \"m-sakura@ccs.mt.nec.co.jp (Mine Sakurai)\"
 298   ->  \"m-sakura@ccs.mt.nec.co.jp\"."
 299   (cond ((string-match ".*<\\([^>]*\\)>" str) ; .* to extract last <>
 300          (wl-match-string 1 str))
 301         ((string-match "\\([^ \t\n]*@[^ \t\n]*\\)" str)
 302          (wl-match-string 1 str))
 303         (t str)))
 304
 305 (defsubst wl-address-header-extract-realname (str)
 306   "Extracts a real name from STR and returns it.
 307 e.g. \"Mr. bar <hoge@foo.com>\"
 308   ->  \"Mr. bar\"."
 309   (cond ((string-match "\\(.*[^ \t]\\)[ \t]*<[^>]*>" str)
 310          (wl-match-string 1 str))
 311         (t "")))
 312
 313 (defun wl-address-petname-delete (the-email)
 314   "Delete petname in wl-address-file."
 315   (let* ( (tmp-buf (get-buffer-create " *wl-petname-tmp*"))
 316           (output-coding-system
 317            (mime-charset-to-coding-system wl-mime-charset)))
 318     (set-buffer tmp-buf)
 319     (message "Deleting Petname...")
 320     (erase-buffer)
 321     (insert-file-contents wl-address-file)
 322     (delete-matching-lines (concat "^[ \t]*" the-email))
 323     (write-region (point-min) (point-max)
 324                   wl-address-file nil 'no-msg)
 325     (message "Deleting Petname...done")
 326     (kill-buffer tmp-buf)))
 327
 328
 329 (defun wl-address-petname-add-or-change (the-email
 330                                          default-petname
 331                                          default-realname
 332                                          &optional change-petname)
 333   "Add petname to wl-address-file, if not registerd.
 334 If already registerd, change it."
 335   (let (the-realname the-petname)
 336
 337     ;; setup output "petname"
 338     ;; if null petname'd, let default-petname be the petname.
 339     (setq the-petname
 340           (read-from-minibuffer (format "Petname: ") default-petname))
 341     (if (string= the-petname "")
 342         (setq the-petname (or default-petname the-email)))
 343
 344     ;; setup output "realname"
 345     (setq the-realname
 346         (read-from-minibuffer (format "Real Name: ") default-realname))
 347 ;;      (if (string= the-realname "")
 348 ;;          (setq the-realname default-petname))
 349
 350     ;; writing to ~/.address
 351     (let ( (tmp-buf (get-buffer-create " *wl-petname-tmp*"))
 352            (output-coding-system (mime-charset-to-coding-system wl-mime-charset)))
 353       (set-buffer tmp-buf)
 354       (message "Adding Petname...")
 355       (erase-buffer)
 356       (if (file-exists-p wl-address-file)
 357           (insert-file-contents wl-address-file))
 358       (if (not change-petname)
 359           ;; if only add
 360           (progn
 361             (goto-char (point-max))
 362             (if (and (> (buffer-size) 0)
 363                      (not (eq (char-after (1- (point-max))) ?\n)))
 364                 (insert "\n")))
 365         ;; if change
 366         (if (re-search-forward (concat "^[ \t]*" the-email) nil t)
 367             (delete-region (save-excursion (beginning-of-line)
 368                                            (point))
 369                            (save-excursion (end-of-line)
 370                                            (+ 1 (point))))))
 371       (insert (format "%s\t\"%s\"\t\"%s\"\n"
 372                       the-email the-petname the-realname))
 373       (write-region (point-min) (point-max)
 374                     wl-address-file nil 'no-msg)
 375       (message "Adding Petname...done")
 376       (kill-buffer tmp-buf))))
 377
 378 (provide 'wl-address)
 379
 380 ;;; wl-address.el ends here