cgit.sxemacs.org Git - packages/blob - xemacs-packages/mew/mew/mew-addrbook.el

   1 ;; mew-addrbook.el --- Completion magic for Mew
   2
   3 ;; Author:  Kazu Yamamoto <Kazu@Mew.org>
   4 ;; Created: Mar 22, 1999
   5 ;; Revised: Aug 30, 1999
   6
   7 ;;; Code:
   8
   9 (defconst mew-addrbook-version "mew-addrbook.el version 0.02")
  10
  11 (require 'mew)
  12
  13 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14 ;;;
  15 ;;; Address book
  16 ;;;
  17
  18 (defvar mew-addrbook-mode-map nil)
  19
  20 (if mew-addrbook-mode-map
  21     ()
  22   (setq mew-addrbook-mode-map (make-sparse-keymap))
  23   (mew-set-keymap-parent mew-addrbook-mode-map text-mode-map)
  24   (define-key mew-addrbook-mode-map "\C-c\C-c" 'mew-addrbook-register)
  25   (define-key mew-addrbook-mode-map "\C-c\C-q" 'mew-addrbook-kill))
  26
  27 (defvar mew-addrbook-mode-alias "Alias")
  28 (defvar mew-addrbook-mode-personalinfo "Personal Info")
  29
  30 (defvar mew-addrbook-strip-domainpart t
  31   "*If *non-nil*, a shortname is created by stripping its domain part.")
  32
  33 ;;
  34
  35 (defvar mew-addrbook-alist nil
  36   "(key addr) or (key (addr1, addr2) nickname name)")
  37 (defvar mew-alias-auto-alist nil
  38   "(key addr)")
  39 (defvar mew-alias-auto-file-name ".mew-alias")
  40
  41 ;;
  42
  43 (defun mew-addrbook-setup ()
  44   (if (and mew-alias-auto-file-name (null mew-alias-auto-alist))
  45       ;; make auto-alist only at the initialization time
  46       ;; not at update time (auto-alist have not been saved yet)
  47       (setq mew-alias-auto-alist (mew-lisp-load mew-alias-auto-file-name)))
  48   (setq mew-addrbook-alist (mew-addrbook-make-alist))
  49   (if (listp mew-addrbook-alist) ;; including nil
  50       ;; mew-alias-auto-alist is used independently so must use copy-alist
  51       (setq mew-addrbook-alist
  52             (nconc mew-addrbook-alist (copy-alist mew-alias-auto-alist)))
  53     ;; addrbook does not exist. Backward compatibility only
  54     (setq mew-addrbook-alist (nconc (mew-alias-make-alist)
  55                                     (copy-alist mew-alias-auto-alist)
  56                                     (mew-petname-make-alist))))
  57   (setq mew-addrbook-alist (mew-uniq-alist mew-addrbook-alist))
  58   (add-hook 'kill-emacs-hook (function mew-addrbook-clean-up)))
  59
  60 (defun mew-addrbook-clean-up ()
  61   (remove-hook 'kill-emacs-hook (function mew-addrbook-clean-up))
  62   (mew-lisp-save mew-alias-auto-file-name mew-alias-auto-alist))
  63
  64 ;;
  65
  66 (defmacro mew-addrbook-func (key)
  67   (` (cdr (assoc (, key) mew-addrbook-switch))))
  68
  69 ;;
  70
  71 (defmacro mew-alias-get (key)
  72   (` (mew-addrbook-alias-get (, key) mew-addrbook-alist)))
  73
  74 (defmacro mew-alias-next (key)
  75   (` (mew-addrbook-alias-next (, key) mew-addrbook-alist)))
  76
  77 (fset 'mew-addrbook-alias-hit (symbol-function 'assoc))
  78
  79 (defun mew-addrbook-alias-get (key alist)
  80   (let ((addrs (mew-addrbook-alias-get1 key alist 0)))
  81     (cond
  82      ((stringp addrs) addrs)
  83      ((listp addrs)
  84       (mapconcat (function identity) (nreverse addrs) ", "))
  85      (t key))))
  86
  87 (defun mew-addrbook-alias-get1 (key alist n)
  88   "Expand KEY to addresses according ALIST.
  89 If addresses is a list, that follows one-of convention and
  90 return the first member of the list.
  91 If addresses is a string, expands it recursively."
  92   (let* ((crnt (nth 1 (mew-addrbook-alias-hit key alist)))
  93          (keys (and (stringp crnt)
  94                     (mapcar (function mew-chop) (mew-split crnt ?,))))
  95          ret tmp)
  96     (cond
  97      ((> n mew-expand-max-depth) key)
  98      ((null crnt) key)
  99      ((listp crnt) (car crnt))
 100      (t
 101       (while keys
 102         (setq tmp (mew-addrbook-alias-get1 (car keys) alist (1+ n)))
 103         (if (listp tmp)
 104             (setq ret (nconc tmp ret))
 105           (setq ret (cons tmp ret)))
 106         (setq keys (cdr keys)))
 107       ret))))
 108
 109 (defun mew-addrbook-alias-next (key alist)
 110   (let* ((addrs (nth 1 (mew-assoc-member key alist 1))))
 111     (if (and addrs (listp addrs))
 112         (mew-get-next addrs key))))
 113
 114 (defun mew-addrbook-alias-add (addr)
 115   (if (and (stringp addr) (string-match "@" addr))
 116       (let* ((user (mew-addrstr-extract-user addr))
 117              (match-auto (assoc user mew-alias-auto-alist))
 118              (match-adbk (assoc user mew-addrbook-alist)))
 119         (cond
 120          (match-auto
 121           (cond
 122            ((equal addr (nth 1 match-auto))
 123             ;; move the entry to the top for the recent-used-first.
 124             (setq mew-alias-auto-alist
 125                   (cons match-auto (delete match-auto mew-alias-auto-alist))))
 126            (mew-addrbook-override-by-newone
 127             ;; override match-auto by (user addr)
 128             (setq mew-addrbook-alist
 129                   (cons (list user addr)
 130                         (delete match-auto mew-addrbook-alist)))
 131             (setq mew-alias-auto-alist
 132                   (cons (list user addr)
 133                         (delete match-auto mew-alias-auto-alist))))
 134            (t
 135             ;; the old entry remains
 136             )))
 137          (match-adbk
 138           ;; do nothing
 139           )
 140          (t
 141           (setq mew-addrbook-alist (cons (list user addr) mew-addrbook-alist))
 142           (setq mew-alias-auto-alist
 143                 (cons (list user addr) mew-alias-auto-alist)))))))
 144
 145 (defun mew-addrbook-alias-delete (addr)
 146   (if (and (stringp addr) (string-match "@" addr))
 147       (let* ((user (mew-addrstr-extract-user addr))
 148              (ent (assoc user mew-alias-auto-alist)))
 149         (if (and ent (equal (cdr ent) addr))
 150             (progn
 151               (setq mew-addrbook-alist (delete ent mew-addrbook-alist))
 152               (setq mew-alias-auto-alist (delete ent mew-alias-auto-alist)))
 153           ))))
 154
 155 ;;
 156
 157 (defun mew-addrbook-shortname-get (addr)
 158   (nth 0 (mew-assoc-member-case-equal addr mew-addrbook-alist 1)))
 159
 160 (defun mew-addrbook-nickname-get (addr)
 161   (nth 2 (mew-assoc-member-case-equal addr mew-addrbook-alist 1)))
 162
 163 (defun mew-addrbook-name-get (addr)
 164   (nth 3 (mew-assoc-member-case-equal addr mew-addrbook-alist 1)))
 165 ;;
 166
 167 (defun mew-addrbook-insert-file (file cregex &optional unquote)
 168   (if (not (stringp file))
 169       ()
 170     (let* ((case-fold-search t)
 171            (pars (mew-split file ?,)) ;; parents
 172            (files pars) ;; included
 173            par chr path beg qchar ret)
 174       ;; include parents files
 175       (while pars
 176         (setq par (car pars))
 177         (setq pars (cdr pars))
 178         (if (not (file-readable-p par))
 179             ()
 180           (setq ret t)
 181           (insert-file-contents par)
 182           (setq path (file-name-directory par))
 183           ;; include children files
 184           (while (re-search-forward "^<[ \t]*\\([^ \t\n]+\\).*$" nil t)
 185             (setq chr (expand-file-name (mew-match 1) path))
 186             (delete-region (match-beginning 0) (match-end 0))
 187             (if (and (file-readable-p chr) (not (member chr files)))
 188                 (progn
 189                   (insert-file-contents chr)
 190                   (setq files (cons chr files)))))
 191           (goto-char (point-max))))
 192       ;; remove commets
 193       (goto-char (point-min))
 194       (while (re-search-forward cregex nil t)
 195         (delete-region (match-beginning 0) (match-end 0)))
 196       ;; concat continuation lines
 197       (goto-char (point-min))
 198       (while (re-search-forward "\\\\\n" nil t)
 199         (delete-region (match-beginning 0) (match-end 0)))
 200       ;; concat separated lines by comma
 201       (goto-char (point-min))
 202       (while (re-search-forward ",$" nil t)
 203         (end-of-line)
 204         (forward-char 1)
 205         (delete-backward-char 1))
 206       ;; replace ", " to "\0" inside/ouside quote.
 207       (goto-char (point-min))
 208       (while (re-search-forward ",[ \t]+" nil t)
 209         (replace-match ",\0" nil t))
 210       ;; unquote, replace white spaces to "\0".
 211       (goto-char (point-min))
 212       (if unquote
 213           (catch 'quote
 214             (while (re-search-forward "[\"']" nil t)
 215               (setq qchar (char-before (point)))
 216               ;; (point) is for backward compatibility
 217               (backward-delete-char 1) ;; delete quote
 218               (setq beg (point))
 219               (if (not (re-search-forward (char-to-string qchar) nil t))
 220                   (throw 'quote nil) ;; error
 221                 (backward-delete-char 1) ;; delete quote
 222                 (save-restriction
 223                   (narrow-to-region beg (point))
 224                   (goto-char (point-min))
 225                   (while (re-search-forward "[ \t]+" nil t)
 226                     (replace-match "\0" nil t))
 227                   (goto-char (point-max))))))) ;; just in case
 228       ;; remove optional white spaces
 229       (goto-char (point-min))
 230       (while (re-search-forward "[ \t]+" nil t)
 231         (replace-match " " nil t))
 232       ret)))
 233
 234 (defun mew-addrbook-strsafe (var)
 235   (if (or (string-equal "" var) (string-equal "*" var))
 236       nil
 237     (mew-replace-character var 0 32)))
 238
 239 (defun mew-addrbook-make-alist ()
 240   (save-excursion
 241     (let (alias colon addrs nick name alist)
 242       (mew-set-buffer-tmp)
 243       (if (not (mew-addrbook-insert-file
 244                 mew-addrbook-file mew-addrbook-comment-regex 'unquote))
 245           'addrbook-does-not-exist
 246         (goto-char (point-min))
 247         (while (re-search-forward "^ ?\\([^ \n:]+\\) ?\\(:?\\) ?\\([^ \n]+\\)" nil t)
 248           (setq alias (mew-addrbook-strsafe (mew-match 1)))
 249           (setq colon (mew-match 2))
 250           (setq addrs (mew-addrbook-strsafe (mew-match 3)))
 251           (if (equal colon ":")
 252               (setq alist (cons (list alias addrs) alist))
 253             (and addrs (setq addrs (mapcar (function mew-chop)
 254                                            (mew-split addrs ?,))))
 255             (if (looking-at " ?\\([^ \n]*\\) ?\\([^ \n]*\\)")
 256                 (progn
 257                   (setq nick (mew-addrbook-strsafe (mew-match 1)))
 258                   (setq name (mew-addrbook-strsafe (mew-match 2))))
 259               (setq nick nil)
 260               (setq name nil))
 261             (setq alist (cons (list alias addrs nick name) alist))))
 262         (nreverse alist)))))
 263
 264 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 265 ;;;
 266 ;;; Addrbook mode
 267 ;;;
 268
 269 (defun mew-summary-addrbook-add (&optional personalinfo)
 270   "Adding the value of From: in Message mode to Addrbook. When
 271 executed with '\\[universal-argument]', it will add personal information.  Otherwise,
 272 it will add an alias."
 273   (interactive "P")
 274   (mew-summary-display nil)
 275   (let ((buf (mew-buffer-message))
 276         from shortname addrs name)
 277     (save-excursion
 278       (set-buffer buf)
 279       (if (mew-header-p)
 280           ()
 281         (setq buf (mew-current-get 'cache))
 282         (if (null buf)
 283             (message "No address to be registered")
 284           (set-buffer buf)))
 285       (setq from (mew-header-get-value mew-from:))
 286       (if (null from)
 287           (message "No address to be registered")
 288         (setq addrs (mew-addrstr-parse-address from))
 289         (if (mew-is-my-address (mew-get-my-address-regex-list) addrs)
 290             (if personalinfo
 291                 (setq addrs (car (mew-header-parse-address-list
 292                                   (list mew-to:))))
 293               (setq addrs
 294                     (mapconcat (function identity)
 295                                (mew-header-parse-address-list
 296                                 (list mew-to: mew-cc:))
 297                                ",")))
 298           (if (string-match "\\(.*\\)<.*>" from)
 299               (progn
 300                 (setq name (mew-match 1 from))
 301                 (setq name (mew-chop name)))))
 302         (if (not addrs)
 303             (message "No address to be registered")
 304           (if mew-addrbook-strip-domainpart
 305               (setq shortname (mew-addrstr-extract-user addrs))
 306             (setq shortname addrs))
 307           (mew-addrbook-prepare-template personalinfo shortname addrs nil name))
 308         ))))
 309
 310 (defun mew-addrbook-prepare-template (personalinfop shortname addrs &optional nickname name)
 311   (delete-other-windows)
 312   (switch-to-buffer (get-buffer-create mew-buffer-addrbook))
 313   (mew-erase-buffer)
 314   (insert "#If you want to register this entry, type "
 315           (substitute-command-keys
 316            "'\\<mew-addrbook-mode-map>\\[mew-addrbook-register]'.\n")
 317           "#If you want to NOT register this entry, type "
 318           (substitute-command-keys
 319            "'\\<mew-addrbook-mode-map>\\[mew-addrbook-kill]'.\n"))
 320   (mew-addrbook-insert-template "Shortname" shortname)
 321   (mew-addrbook-insert-template "Addresses" addrs)
 322   (cond
 323    (personalinfop
 324     (mew-addrbook-insert-template "Nickname" nickname)
 325     (mew-addrbook-insert-template "Name" name)
 326     (mew-addrbook-mode mew-addrbook-mode-personalinfo))
 327    (t
 328     (mew-addrbook-mode mew-addrbook-mode-alias)))
 329   (mew-addrbook-insert-template "Comments" nil)
 330   (goto-char (point-min))
 331   (search-forward ": " nil t))
 332
 333 (defun mew-addrbook-insert-template (key val)
 334   (mew-elet
 335    (let ((beg (point)))
 336      (insert key ": ")
 337      (put-text-property beg (point) 'read-only t)
 338      (mew-rear-nonsticky beg (point))
 339      (and val (insert val))
 340      (insert "\n"))))
 341
 342 (defun mew-addrbook-mode (mname)
 343   "\\<mew-addrbook-mode-map>
 344 Mew Addrbook mode:: major mode to register Addrbook.
 345 The keys that are defined for this mode are:
 346
 347 \\[mew-addrbook-register]       Register information in Addrbook mode to Addrbook.
 348 \\[mew-addrbook-kill]   Kill Addrbook mode.
 349 "
 350   (interactive)
 351   (setq major-mode 'mew-addrbook-mode)
 352   (setq mode-name mname)
 353   (setq mode-line-buffer-identification mew-mode-line-id)
 354   (use-local-map mew-addrbook-mode-map)
 355   (run-hooks 'mew-addrbook-mode-hook)
 356   (setq buffer-undo-list nil))
 357
 358 (defun mew-addrbook-register ()
 359   "Register information in Addrbook mode to Addrbook."
 360   (interactive)
 361   (let ((shortname (mew-header-get-value "Shortname:"))
 362         (addrs     (mew-header-get-value "Addresses:"))
 363         (nickname  (mew-header-get-value "Nickname:"))
 364         (name      (mew-header-get-value "Name:"))
 365         (comments  (mew-header-get-value "Comments:"))
 366         (mode mode-name)
 367         buf addrsl errmsg not-uniq)
 368      (cond
 369       ((equal mode mew-addrbook-mode-alias)
 370        (cond
 371         ((and (null shortname) (null addrs))
 372          (setq errmsg "Must fill both Shortname and Addresses."))
 373         ((null shortname)
 374          (setq errmsg "Must fill Shortname."))
 375         ((null addrs)
 376          (setq errmsg "Must fill Addresses."))))
 377       (t
 378        (cond
 379         ((null addrs)
 380          (setq errmsg "Must fill Addresses."))
 381         ((and (null shortname) (null nickname) (null name))
 382          (setq errmsg "Must fill Shortname or Nickname or Name."))
 383         ((and name (string-match "^\"[^\"]*[^\000-\177]" name))
 384          (setq errmsg "Remove quote around non-ASCII Name.")))))
 385      (if errmsg
 386          (message errmsg)
 387        (save-excursion
 388          (setq buf (find-file-noselect mew-addrbook-file))
 389          (set-buffer buf)
 390          (goto-char (point-min))
 391          (if (and shortname
 392                   (re-search-forward
 393                    (concat "^" (regexp-quote shortname) "[ \t]*:?[ \t]+") nil t))
 394              (setq not-uniq t))
 395          (if not-uniq
 396              () ;; see later
 397            ;; All errors are checked.
 398            (goto-char (point-max))
 399            (if (not (bolp)) (insert "\n"))
 400            (cond
 401             ((equal mode mew-addrbook-mode-alias)
 402              (setq mew-addrbook-alist
 403                    (cons (list shortname addrs) mew-addrbook-alist))
 404              (insert shortname ":\t" addrs))
 405             (t
 406              (setq addrsl (mew-addrstr-parse-address-list addrs))
 407              (setq mew-addrbook-alist
 408                    (cons (list shortname addrsl nickname name) mew-addrbook-alist))
 409              (if (null shortname) (setq shortname "*"))
 410              (if (and nickname (string-match "^[^\" \t]+[ \t]+.*$" nickname))
 411                  (setq nickname (concat "\"" nickname "\"")))
 412              (if (and name (string-match "^[^\" \t]+[ \t]+.*$" name))
 413                  (setq name (concat "\"" name "\"")))
 414              (if name
 415                  (insert shortname "\t" addrs "\t" (or nickname "*") "\t" name)
 416                (if nickname
 417                    (insert shortname "\t" addrs "\t" nickname)
 418                  (insert shortname "\t" addrs)))))
 419            (if comments
 420                (insert "\t#" comments "\n")
 421              (insert "\n"))
 422            (save-buffer)))
 423        ;; Addrbook buffer
 424        (kill-buffer buf)
 425        (if not-uniq
 426            (message "Shortname is already used. Change Shortname.")
 427          (mew-addrbook-kill 'no-msg)
 428          (message "Registered to Addrbook.")))))
 429
 430 (defun mew-addrbook-kill (&optional no-msg)
 431   "Kill Addrbook mode."
 432   (interactive "P")
 433   (kill-buffer (current-buffer))
 434   (or no-msg (message "Not registered.")))
 435
 436 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 437 ;;;
 438 ;;; Old aliases and petnames
 439 ;;;
 440
 441 (defun mew-alias-make-alist ()
 442   "Make alias alist with association of (alias . expantion).
 443 Currently, only 'user: user@domain' syntax is supported."
 444   (save-excursion
 445     (let (alias expn alist)
 446       (mew-set-buffer-tmp)
 447       (mew-addrbook-insert-file mew-alias-file mew-alias-comment-regex)
 448       (goto-char (point-min))
 449       (while (re-search-forward "^ ?\\([^ \n:]+\\) ?: ?\\(.*\\)$" nil t)
 450         (setq alias (mew-addrbook-strsafe (mew-match 1)))
 451         (setq expn (mew-addrbook-strsafe (mew-match 2)))
 452         ;; append for first assoc comes first
 453         (setq alist (cons (list alias expn) alist)))
 454       (nreverse alist))))
 455
 456 (defun mew-petname-make-alist ()
 457   (if (and mew-petname-file (file-readable-p mew-petname-file))
 458       (save-excursion
 459         (let (ret)
 460           (mew-set-buffer-tmp)
 461           (insert-file-contents mew-petname-file)
 462           (goto-char (point-min))
 463           (while (not (eobp))
 464             (if (looking-at "^\\([^ \t]+\\)[ \t]+\"?\\([^\"\n]+\\)\"?$")
 465                 (setq ret (cons (list nil (list (mew-match 1)) (mew-match 2) nil) ret)))
 466             (forward-line))
 467           ret))))
 468
 469 (provide 'mew-addrbook)
 470
 471 ;;; Copyright Notice:
 472
 473 ;; Copyright (C) 1999 Mew developing team.
 474 ;; All rights reserved.
 475
 476 ;; Redistribution and use in source and binary forms, with or without
 477 ;; modification, are permitted provided that the following conditions
 478 ;; are met:
 479 ;;
 480 ;; 1. Redistributions of source code must retain the above copyright
 481 ;;    notice, this list of conditions and the following disclaimer.
 482 ;; 2. Redistributions in binary form must reproduce the above copyright
 483 ;;    notice, this list of conditions and the following disclaimer in the
 484 ;;    documentation and/or other materials provided with the distribution.
 485 ;; 3. Neither the name of the team nor the names of its contributors
 486 ;;    may be used to endorse or promote products derived from this software
 487 ;;    without specific prior written permission.
 488 ;;
 489 ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' AND
 490 ;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 491 ;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
 492 ;; PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE TEAM OR CONTRIBUTORS BE
 493 ;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 494 ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 495 ;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
 496 ;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
 497 ;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
 498 ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
 499 ;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 500
 501 ;;; mew-addrbook.el ends here