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