From 8b5f252276cfcb769e3ba669677630f3f4072f0c Mon Sep 17 00:00:00 2001 From: murata Date: Sat, 22 Sep 2001 04:03:15 +0000 Subject: [PATCH] Add wl-addrbook.el and wl-complete.el to utils. --- WL-ELS | 2 +- doc/wl-ja.texi | 21 +- doc/wl.texi | 20 +- utils/wl-addrbook.el | 621 ++++++++++++++++++++++++++++++++++++++++++++++++++ utils/wl-complete.el | 396 ++++++++++++++++++++++++++++++++ 5 files changed, 1057 insertions(+), 3 deletions(-) create mode 100644 utils/wl-addrbook.el create mode 100644 utils/wl-complete.el diff --git a/WL-ELS b/WL-ELS index 69f6c8e..785548d 100644 --- a/WL-ELS +++ b/WL-ELS @@ -59,7 +59,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Utils -(defvar UTILS-MODULES '(rfc2368 wl-mailto)) +(defvar UTILS-MODULES '(rfc2368 wl-mailto wl-addrbook wl-complete)) ;; OpenSSL/SSLeay package is also needed. (if (module-installed-p 'base64) diff --git a/doc/wl-ja.texi b/doc/wl-ja.texi index df3c4f5..51d5085 100644 --- a/doc/wl-ja.texi +++ b/doc/wl-ja.texi @@ -5919,6 +5919,7 @@ LDAP $B$rMxMQ$9$k>l9g$O!"(B@code{wl-ldap-server}$B!"(B@code{wl-ldap-port}, * X-Face:: x-face,bitmap-mule * dired-dd:: dired-dd.el * MHC:: MHC +* Addrbook:: Addrbook @end menu @@ -6109,7 +6110,7 @@ Emacs $B$GJT=8Cf$NAp9F%P%C%U%!$X(B dired $B$+$i%I%i%C%0(B&$B%I%m%C%W$9$k$@$ @end group @end lisp -@node MHC, , dired-dd, Living with other packages +@node MHC, Addrbook, dired-dd, Living with other packages @subsection mhc.el @pindex MHC @@ -6138,6 +6139,24 @@ mhc-current $B$N>l9g!'(B @end group @end lisp +@node Addrbook, , MHC, Living with other packages +@subsection wl-addrbook.el +@pindex Addrbook + +Addrbook of Mew +(@uref{http://www.mew.org/}) + +Mew $B$N(B Addrbook $B$r(B Wanderlust $B$G;HMQ$G$-$k$h$&$K$9$k$K$O!"(B +@file{util/wl-addrbook.el} $B$H(B @file{util/wl-complete.el} $B$r(B +@code{load-path} $B$K$*$$$F!"0J2<$N$h$&$K@_Dj$7$^$9!#(B + +@lisp +@group +(require 'wl-addrbook) +(wl-addrbook-setup) +@end group +@end lisp + @node Highlights, Biff, Living with other packages, Customization @section $B%O%$%i%$%H$N@_Dj(B diff --git a/doc/wl.texi b/doc/wl.texi index 1c69a02..9bc2fb4 100644 --- a/doc/wl.texi +++ b/doc/wl.texi @@ -6007,6 +6007,7 @@ Examples with other packages. * X-Face:: x-face,bitmap-mule * dired-dd:: dired-dd.el * MHC:: MHC +* Addrbook:: Addrbook @end menu @@ -6196,7 +6197,7 @@ specific, but general-purpose for SEMI). @end group @end lisp -@node MHC, , dired-dd, Living with other packages +@node MHC, Addrbook, dired-dd, Living with other packages @subsection mhc.el @pindex MHC @@ -6225,6 +6226,23 @@ For mhc-current: @end group @end lisp +@node Addrbook, , MHC, Living with other packages +@subsection wl-addrbook.el +@pindex Addrbook + +Addrbook of Mew +(@uref{http://www.mew.org/}) + +Place @file{util/wl-addrbook.el} and @file{util/wl-complete.el} on the +@code{load-path} and do the following settings. + +@lisp +@group +(require 'wl-addrbook) +(wl-addrbook-setup) +@end group +@end lisp + @node Highlights, Biff, Living with other packages, Customization @section Highlights diff --git a/utils/wl-addrbook.el b/utils/wl-addrbook.el new file mode 100644 index 0000000..a650467 --- /dev/null +++ b/utils/wl-addrbook.el @@ -0,0 +1,621 @@ +;; wl-addrbook.el --- Aliases and personal information + +;; Author: Masahiro MURATA +;; Kazu Yamamoto +;; Keywords: mail, net news + +;;; Commentary: + +;; Insert the following lines in your ~/.wl +;; +;; (require 'wl-addrbook) +;; (wl-addrbook-setup) + +;; Original code: Kazu Yamamoto +;; mew-addrbook.el (Mew developing team) + +;;; Code: + +(require 'wl-util) + +(defvar wl-addrbook-file "~/.im/Addrbook" + "*Addrbook file for completion") +(defvar wl-addrbook-expand-max-depth 5 + "*A value to limit alias(addrbook) expansion loop.") +(defvar wl-addrbook-comment-regexp "^;.*$\\|#.*$" + "*Regular expression for \".im/Addrbook\".") +(defvar wl-addrbook-override-by-newone t + "If non-nil, the 'user' entry in 'wl-alias-auto-alist' +is override by a new entry of (user different-address). +This means that addresses in To: and Cc: in Draft mode are +always learned with an exception 'user' is defined in Addrbook. +If nil, the old 'user' entry remains.") + +;;(defvar wl-anonymous-recipients ":;") + +(defvar wl-addrbook-hashtb nil) + +(defvar wl-addrbook-strip-domainpart t + "*If *non-nil*, a shortname is created by stripping its domain part.") + +(defvar wl-addrbook-alist nil + "(key addr) or (key (addr1, addr2) nickname name)") +(defvar wl-alias-auto-alist nil + "(key addr)") +(defvar wl-alias-auto-file-name "auto-alias") + +(defvar wl-summary-use-addrbook-from-func t) + +;;; utils + +(defun wl-uniq-alist (alst) + "Distractively uniqfy elements of ALST." + (let ((tmp alst)) + (while tmp (setq tmp (setcdr tmp (wl-delete-alist2 (car (car tmp)) (cdr tmp)))))) + alst) + +(defun wl-delete-alist2 (key alist) + "Destructively delete elements whose first member is equal to key" + (if (null key) + alist + (let (ret) + (while (equal (car (nth 0 alist)) key) + (setq alist (cdr alist))) + (setq ret alist) + (while alist + (if (equal (car (nth 1 alist)) key) + (setcdr alist (cdr (cdr alist))) + (setq alist (cdr alist)))) + ret))) + +(defun wl-get-next (LIST MEM) + (let (frst next crnt) + (setq frst (car LIST)) + (setq LIST (cdr LIST)) + (setq next (car LIST)) + (if (equal frst MEM) + (if next next frst) + (catch 'loop + (while LIST + (setq crnt next) + (setq LIST (cdr LIST)) + (setq next (car LIST)) + (if (equal crnt MEM) + (throw 'loop (if next next frst)))))))) + +(defun wl-address-extract-user (addr) + "Extracts username from ADDR" + (if (string-match "@.*:" addr) ;; xxx what's this? + (setq addr (substring addr (match-end 0) nil)) + (setq addr (elmo-replace-in-string addr " " "_")) + (setq addr (substring addr 0 (string-match "%" addr))) + (setq addr (substring addr 0 (string-match "@" addr))) + ;; just for refile: "To: recipients:;" -> recipients + ;;(setq addr (substring addr 0 (string-match wl-anonymous-recipients addr))) + ;; removing Notes domain + (setq addr (substring addr 0 (string-match "/" addr))))) + +(defun wl-address-parse-address-list (addrs) + (mapcar 'wl-address-header-extract-address (wl-parse-addresses addrs))) + +;; hash table for wl-addrbook-alist +(defmacro wl-addrbook-hashtb () + (` (or wl-addrbook-hashtb + (setq wl-addrbook-hashtb (elmo-make-hash 1021))))) + +(defsubst wl-addrbook-get-record-by-addr (addr &optional alist) + (elmo-get-hash-val (downcase addr) (wl-addrbook-hashtb))) + +(defsubst wl-addrbook-get-record-by-alias (alias &optional alist) + (elmo-get-hash-val (format "#%s" (downcase alias)) (wl-addrbook-hashtb))) + +(defun wl-addrbook-make-hashtb () + (let ((ht (wl-addrbook-hashtb)) + (alist wl-addrbook-alist) + list addrs addr) + (while alist + (setq list (car alist) + alist (cdr alist)) + ;; key is alias + (if (car list) + (elmo-set-hash-val (format "#%s" (downcase (car list))) list ht)) + (when (listp (setq addrs (nth 1 list))) + (while addrs + (setq addr (car addrs) + addrs (cdr addrs)) + ;; key is address + (elmo-set-hash-val (downcase addr) list ht)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Address book +;;; + +(defun wl-addrbook-setup () + (require 'wl-complete) + ;; replace wl-address-init function. + (setq wl-address-init-function 'wl-addrbook-init) + ;; + (when wl-summary-use-addrbook-from-func + (setq wl-summary-from-function 'wl-summary-addrbook-from)) + (define-key wl-summary-mode-map "\C-c\C-a" 'wl-summary-addrbook-add) + (define-key wl-draft-mode-map "\C-i" 'wl-draft-addrbook-header-comp-or-tab) + (define-key wl-draft-mode-map "\e\t" 'wl-draft-addrbook-expand) + (define-key wl-draft-mode-map "\C-c\t" 'wl-draft-circular-comp) + (add-hook 'mail-send-hook 'wl-draft-learn-alias)) + +(defun wl-addrbook-init () + (message "Updating addrbook...") + (or wl-alias-auto-alist + (if wl-alias-auto-file-name + (setq wl-alias-auto-alist + (elmo-object-load (expand-file-name + wl-alias-auto-file-name + elmo-msgdb-dir))))) + (setq wl-addrbook-alist (wl-addrbook-make-alist)) + ;; wl-alias-auto-alist is used independently so must use copy-alist + (if wl-addrbook-alist + (nconc wl-addrbook-alist (copy-alist wl-alias-auto-alist)) + (setq wl-addrbook-alist (copy-alist wl-alias-auto-alist))) +;; (if wl-addrbook-alist +;; (nconc wl-addrbook-alist (wl-petname-make-alist)) +;; (setq wl-addrbook-version (wl-petname-make-alist))) + (setq wl-addrbook-alist (wl-uniq-alist wl-addrbook-alist)) + (wl-addrbook-make-hashtb) + (add-hook 'kill-emacs-hook (function wl-addrbook-clean-up)) + (add-hook 'wl-exit-hook (function wl-addrbook-clean-up)) + (message "Updating addrbook...done.")) + +(defun wl-addrbook-clean-up () + (remove-hook 'kill-emacs-hook (function wl-addrbook-clean-up)) + (remove-hook 'wl-exit-hook (function wl-addrbook-clean-up)) + (when wl-alias-auto-file-name + (elmo-object-save (expand-file-name + wl-alias-auto-file-name + elmo-msgdb-dir) + wl-alias-auto-alist) + (setq wl-alias-auto-alist nil) + (setq wl-addrbook-hashtb nil))) + +;; + +(defmacro wl-alias-get (key) + (` (wl-addrbook-alias-get (, key) wl-addrbook-alist))) + +(defmacro wl-alias-next (key) + (` (wl-addrbook-alias-next (, key) wl-addrbook-alist))) + +(defalias 'wl-addrbook-alias-hit 'wl-addrbook-get-record-by-alias) + +(defun wl-addrbook-alias-get (key alist) + (let ((addrs (wl-addrbook-alias-get1 key alist 0))) + (cond + ((stringp addrs) addrs) + ((listp addrs) + (mapconcat (lambda (x) x) (nreverse addrs) ", ")) + (t key)))) + +(defun wl-addrbook-alias-get1 (key alist n) + "Expand KEY to addresses according ALIST. +If addresses is a list, that follows one-of convention and +return the first member of the list. +If addresses is a string, expands it recursively." + (let* ((crnt (nth 1 (wl-addrbook-alias-hit key alist))) + (keys (and (stringp crnt) + (elmo-parse crnt "\\([^, \t]+\\)"))) + ret tmp) + (cond + ((> n wl-addrbook-expand-max-depth) key) + ((null crnt) key) + ((listp crnt) (car crnt)) + (t + (while keys + (setq tmp (wl-addrbook-alias-get1 (car keys) alist (1+ n))) + (if (listp tmp) + (setq ret (nconc tmp ret)) + (setq ret (cons tmp ret))) + (setq keys (cdr keys))) + ret)))) + +(defun wl-addrbook-alias-next (key alist) + (let* ((addrs (nth 1 (wl-addrbook-get-record-by-addr key alist)))) + (if (and addrs (listp addrs)) + (wl-get-next addrs key)))) + +(defun wl-addrbook-alias-add (addr) + (if (and (stringp addr) (string-match "@" addr)) + (let* ((user (wl-address-extract-user addr)) + (match-auto (assoc user wl-alias-auto-alist)) + (match-adbk (assoc user wl-addrbook-alist))) + (cond + (match-auto + (cond + ((equal addr (nth 1 match-auto)) + ;; move the entry to the top for the recent-used-first. + (setq wl-alias-auto-alist + (cons match-auto (delete match-auto wl-alias-auto-alist)))) + (wl-addrbook-override-by-newone + ;; override match-auto by (user addr) + (setq wl-addrbook-alist + (cons (list user addr) + (delete match-auto wl-addrbook-alist))) + (setq wl-alias-auto-alist + (cons (list user addr) + (delete match-auto wl-alias-auto-alist)))) + (t + ;; the old entry remains + ))) + (match-adbk + ;; do nothing + ) + (t + (setq wl-addrbook-alist (cons (list user addr) wl-addrbook-alist)) + (setq wl-alias-auto-alist + (cons (list user addr) wl-alias-auto-alist))))))) + +(defun wl-addrbook-alias-delete (addr) + (if (and (stringp addr) (string-match "@" addr)) + (let* ((user (wl-address-extract-user addr)) + (ent (assoc user wl-addrbook-alist))) + (if (and ent (equal (cdr ent) addr)) + (progn + (setq wl-addrbook-alist (delete ent wl-addrbook-alist)) + (setq wl-alias-auto-alist (delete ent wl-alias-auto-alist))))))) + +;; + +(defun wl-addrbook-shortname-get (addr) + (nth 0 (wl-addrbook-get-record-by-addr addr))) + +(defun wl-addrbook-nickname-get (addr) + (nth 2 (wl-addrbook-get-record-by-addr addr))) + +(defun wl-addrbook-name-get (addr) + (nth 3 (wl-addrbook-get-record-by-addr addr))) +;; + +(defun wl-addrbook-insert-file (file cregexp &optional unquote) + (let* ((case-fold-search t) + (coding-system-for-read wl-cs-autoconv) + (pars (elmo-parse file "\\([^, ]+\\)")) ;; parents + (files pars) ;; included + par chr path beg qchar) + ;; include parents files + (while pars + (setq par (car pars)) + (setq pars (cdr pars)) + (if (not (file-readable-p par)) + () + (insert-file-contents par) + (setq path (file-name-directory par)) + ;; include children files + (while (re-search-forward "^\<[ \t]*\\([^ \t\n]+\\).*$" nil t) + (setq chr (expand-file-name (wl-match-buffer 1) path)) + (delete-region (match-beginning 0) (match-end 0)) + (if (and (file-readable-p chr) (not (member chr files))) + (progn + (insert-file-contents chr) + (setq files (cons chr files))))) + (goto-char (point-max)))) + ;; remove commets + (goto-char (point-min)) + (while (re-search-forward cregexp nil t) + (delete-region (match-beginning 0) (match-end 0))) + ;; concat continuation lines + (goto-char (point-min)) + (while (re-search-forward "\\\\\n" nil t) + (delete-region (match-beginning 0) (match-end 0))) + ;; concat separated lines by comma + (goto-char (point-min)) + (while (re-search-forward ",[ \t]*$" nil t) + (end-of-line) + (forward-char 1) + (delete-backward-char 1) + (delete-horizontal-space)) + ;; unquote, replace white spaces to "\0". + (if unquote + (catch 'quote + (goto-char (point-min)) + (while (re-search-forward "[\"']" nil t) + (setq qchar (char-before (point))) + ;; (point) is for backward compatibility + (backward-delete-char 1) ;; delete quote + (setq beg (point)) + (if (not (re-search-forward (char-to-string qchar) nil t)) + (throw 'quote nil) ;; error + (backward-delete-char 1) ;; delete quote + (save-restriction + (narrow-to-region beg (point)) + (goto-char (point-min)) + (while (re-search-forward "[ \t]+" nil t) + (replace-match "\0")) + (goto-char (point-max))))))) ;; just in case + ;; remove optional white spaces + (goto-char (point-min)) + (while (re-search-forward "[ \t]+" nil t) + (replace-match " ")))) + +(defun wl-addrbook-strsafe (var) + (if (or (string-equal "" var) (string-equal "*" var)) + nil + (save-match-data + (elmo-replace-in-string var (char-to-string 0) " ")))) + +(defun wl-addrbook-make-alist () + (let (alias colon addrs nick name alist) + (wl-set-work-buf + (wl-addrbook-insert-file + wl-addrbook-file wl-addrbook-comment-regexp 'unquote) + (goto-char (point-min)) + (while (re-search-forward "^ ?\\([^ \n:]+\\) ?\\(:?\\) ?\\([^ \n]+\\)" nil t) + (setq alias (wl-addrbook-strsafe (wl-match-buffer 1))) + (setq colon (wl-match-buffer 2)) + (setq addrs (wl-addrbook-strsafe (wl-match-buffer 3))) + (if (equal colon ":") + (setq alist (cons (list alias addrs) alist)) + (and addrs (setq addrs (elmo-parse addrs "\\([^, \t\r\n]+\\)"))) + (if (looking-at " ?\\([^ \n]*\\) ?\\([^ \n]*\\)") + (progn + (setq nick (wl-addrbook-strsafe (wl-match-buffer 1))) + (setq name (wl-addrbook-strsafe (wl-match-buffer 2)))) + (setq nick nil) + (setq name nil)) + (setq alist (cons (list alias addrs nick name) alist)))) + (nreverse alist)))) + +(defun wl-draft-learn-alias () + (interactive) + (let ((recipients (mapconcat 'identity + (delq nil (std11-field-bodies '("To" "Cc"))) + ","))) + (mapcar '(lambda (addr) + (wl-addrbook-alias-add + (wl-address-header-extract-address addr))) + (wl-parse-addresses recipients)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Addrbook mode +;;; + +(defvar wl-addrbook-mode-map nil) + +(if wl-addrbook-mode-map + () + ;;(setq wl-addrbook-mode-map (make-sparse-keymap)) + ;;(set-keymap-parent wl-addrbook-mode-map text-mode-map) + (setq wl-addrbook-mode-map (copy-keymap text-mode-map)) + (define-key wl-addrbook-mode-map "\C-c\C-c" 'wl-addrbook-register) + (define-key wl-addrbook-mode-map "\C-c\C-q" 'wl-addrbook-kill)) + +(defvar wl-addrbook-mode-alias "Alias") +(defvar wl-addrbook-mode-personalinfo "Personal Info") +(defconst wl-addrbook-buffer-name "*WL Addrbook*") + +(defun wl-summary-addrbook-add (&optional personalinfo) + "Adding the value of From: or To: in Message mode to Addrbook. When +executed with '\\[universal-argument]', it will add personal information. Otherwise, +it will add an alias." + (interactive "P") + (wl-summary-redisplay) + (let ((buf wl-message-buffer) + from shortname address addrs name) + (save-excursion + (set-buffer buf) + (setq address (std11-field-body "From")) + (if (wl-address-user-mail-address-p address) + (setq address (std11-field-body "To"))) + (if (null address) + (message "No address to be registered") + (setq addrs (wl-address-header-extract-address address)) + (if wl-addrbook-strip-domainpart + (setq shortname (wl-address-extract-user addrs)) + (setq shortname addrs)) + (if (string-match "\\(.*\\)<.*>" address) + (progn + (setq name (wl-match-string 1 address)) + (setq name (elmo-replace-in-string name "[ \t]$" "")))) + (wl-addrbook-prepare-template personalinfo shortname addrs nil name))))) + +(defun wl-addrbook-prepare-template (personalinfop shortname addrs &optional nickname name) + (delete-other-windows) + (switch-to-buffer (get-buffer-create wl-addrbook-buffer-name)) + (erase-buffer) + (insert "#If you want to register this entry, type " + (substitute-command-keys + "'\\\\[wl-addrbook-register]'.\n") + "#If you want to NOT register this entry, type " + (substitute-command-keys + "'\\\\[wl-addrbook-kill]'.\n")) + (wl-addrbook-insert-template "Shortname" shortname) + (wl-addrbook-insert-template "Addresses" addrs) + (cond + (personalinfop + (wl-addrbook-insert-template "Nickname" nickname) + (wl-addrbook-insert-template "Name" name) + (wl-addrbook-mode wl-addrbook-mode-personalinfo)) + (t + (wl-addrbook-mode wl-addrbook-mode-alias))) + (wl-addrbook-insert-template "Comments" nil) + (goto-char (point-min)) + (search-forward ": " nil t)) + +(defun wl-addrbook-insert-template (key val) + (let ((buffer-read-only nil) + (inhibit-read-only t) + (beg (point))) + (insert key ": ") + (put-text-property beg (point) 'read-only t) + (put-text-property (1- (point)) (point) + (if wl-on-xemacs 'end-open 'rear-nonsticky) + t) + (and val (insert val)) + (insert "\n"))) + +(defun wl-addrbook-mode (mname) + "\\ +Mew Addrbook mode:: major mode to resistor Addrbook. +The keys that are defined for this mode are: + +\\[wl-addrbook-register] Register information in Addrbook mode to Addrbook. +\\[wl-addrbook-kill] Kill Addrbook mode. +" + (interactive) + (setq major-mode 'wl-addrbook-mode) + (setq mode-name mname) + (setq mode-line-buffer-identification + (format "Wanderlust: %s" mname)) + (use-local-map wl-addrbook-mode-map) + (run-hooks 'wl-addrbook-mode-hook) + (setq buffer-undo-list nil)) + +(defun wl-addrbook-register () + "Register information in Addrbook mode to Addrbook." + (interactive) + (let ((shortname (std11-field-body "Shortname")) + (addrs (std11-field-body "Addresses")) + (nickname (std11-field-body "Nickname")) + (name (std11-field-body "Name")) + (comments (std11-field-body "Comments")) + (mode mode-name) + buf addrsl errmsg not-uniq) + (cond + ((equal mode wl-addrbook-mode-alias) + (cond + ((and (null shortname) (null addrs)) + (setq errmsg "Must fill both Shortname and Addresses.")) + ((null shortname) + (setq errmsg "Must fill Shortname.")) + ((null addrs) + (setq errmsg "Must fill Addresses.")))) + (t + (cond + ((null addrs) + (setq errmsg "Must fill Addresses.")) + ((and (null shortname) (null nickname) (null name)) + (setq errmsg "Must fill Shortname or Nickname or Name.")) + ((and name (string-match "^\"[^\"]*[^\000-\177]" name)) + (setq errmsg "Remove quote around non-ASCII Name."))))) + (if errmsg + (message errmsg) + (save-excursion + (setq buf (find-file-noselect wl-addrbook-file)) + (set-buffer buf) + (goto-char (point-min)) + (if (and shortname + (re-search-forward + (concat "^" (regexp-quote shortname) "[ \t]*:?[ \t]+") nil t)) + (setq not-uniq t)) + (if not-uniq + () ;; see later + ;; All errors are checked. + (goto-char (point-max)) + (if (not (bolp)) (insert "\n")) + (cond + ((equal mode wl-addrbook-mode-alias) + (setq wl-addrbook-alist + (cons (list shortname addrs) wl-addrbook-alist)) + (insert shortname ":\t" addrs)) + (t + (setq addrsl (wl-address-parse-address-list addrs)) + (setq wl-addrbook-alist + (cons (list shortname addrsl nickname name) wl-addrbook-alist)) + (if (null shortname) (setq shortname "*")) + (if (and nickname (string-match "^[^\" \t]+[ \t]+.*$" nickname)) + (setq nickname (concat "\"" nickname "\""))) + (if (and name (string-match "^[^\" \t]+[ \t]+.*$" name)) + (setq name (concat "\"" name "\""))) + (if name + (insert shortname "\t" addrs "\t" (or nickname "*") "\t" name) + (if nickname + (insert shortname "\t" addrs "\t" nickname) + (insert shortname "\t" addrs))))) + (if comments + (insert "\t#" comments "\n") + (insert "\n")) + (save-buffer))) + (wl-addrbook-make-hashtb) + ;; Addrbook buffer + (kill-buffer buf) + (if not-uniq + (message "Shortname is already used. Change Shortname.") + (wl-addrbook-kill 'no-msg) + (message "Registered to Addrbook."))))) + +(defun wl-addrbook-kill (&optional no-msg) + "Kill Addrbook mode." + (interactive "P") + (kill-buffer (current-buffer)) + (or no-msg (message "Not registered."))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Show nick name of Addrbook in summary. +;;; + +(defsubst wl-addrbook-get-names (names) + (let (addrs) + (mapconcat + (function + (lambda (name) + (or (wl-addrbook-nickname-get + (wl-address-header-extract-address name)) + (and (setq addrs (std11-extract-address-components name)) + (or (car addrs) (cadr addrs)))))) + (wl-parse-addresses names) + ","))) + +(eval-when-compile (defvar-maybe entity nil)) ; silence byte compiler. +(defun wl-summary-addrbook-from (from) + "A candidate for wl-summary-from-function. +Show destination in summary matched by `wl-summary-show-dest-folder-regexp'. +And use Addrbook for get user name." + (let ((fromaddr (wl-address-header-extract-address from)) + dest) + (or + (and (eq major-mode 'wl-summary-mode) + (string-match wl-summary-showto-folder-regexp + wl-summary-buffer-folder-name) + (wl-address-user-mail-address-p fromaddr) + (cond ((setq dest (elmo-msgdb-overview-entity-get-to entity)) + (concat "To:" (eword-decode-string (wl-addrbook-get-names dest)))) + ((setq dest (elmo-msgdb-overview-entity-get-extra-field + entity "newsgroups")) + (concat "Ng:" dest)))) + (wl-addrbook-nickname-get fromaddr) + from))) + +(provide 'wl-addrbook) + +;;; Copyright Notice: + +;; Copyright (C) 1999-2001 Mew developing team. +;; Copyright (C) 2001 Masahiro Murata +;; All rights reserved. + +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; 1. Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; 2. Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; 3. Neither the name of the team nor the names of its contributors +;; may be used to endorse or promote products derived from this software +;; without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' AND +;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE TEAM OR CONTRIBUTORS BE +;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN +;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; wl-addrbook.el ends here diff --git a/utils/wl-complete.el b/utils/wl-complete.el new file mode 100644 index 0000000..70dfc68 --- /dev/null +++ b/utils/wl-complete.el @@ -0,0 +1,396 @@ +;;; wl-complete.el --- Completion magic for Wanderlust + +;; Author: Masahiro MURATA +;; Kazu Yamamoto +;; Keywords: mail, net news + +;;; Commentary: + +;; Insert the following lines in your ~/.wl +;; +;; (require 'wl-addrbook) +;; (wl-addrbook-setup) + +;; Original code: Kazu Yamamoto +;; mew-complete.el (Mew developing team) + +;;; Code: + +(require 'wl-util) +(require 'wl-addrbook) + +(defvar wl-mail-domain-list nil) +(defvar wl-from-list nil) + +(defvar wl-complete-lwsp "^[ \t]") +(defvar wl-complete-address-separator ":, \t\n") + +(defvar wl-field-completion-switch + '(("To:" . wl-addrbook-complete-address) + ("Cc:" . wl-addrbook-complete-address) + ("Dcc:" . wl-addrbook-complete-address) + ("Bcc:" . wl-addrbook-complete-address) + ("Reply-To:" . wl-addrbook-complete-address) + ("Mail-Reply-To:" . wl-addrbook-complete-address) + ("Return-Receipt-To:" . wl-addrbook-complete-address) + ("Newsgroups:" . wl-complete-newsgroups) + ("Followup-To:" . wl-complete-newsgroups) + ("Fcc:" . wl-complete-folder) + ) + "*Completion function alist concerned with the key.") + +(defvar wl-field-circular-completion-switch + '(("To:" . wl-circular-complete-domain) + ("Cc:" . wl-circular-complete-domain) + ("Dcc:" . wl-circular-complete-domain) + ("Bcc:" . wl-circular-complete-domain) + ("Reply-To:" . wl-circular-complete-domain) + ("From:" . wl-circular-complete-from)) + "*Circular completion function alist concerned with the key.") + +(defvar wl-field-expansion-switch + '(("To:" . wl-addrbook-expand-address) + ("Cc:" . wl-addrbook-expand-address) + ("Dcc:" . wl-addrbook-expand-address) + ("Bcc:" . wl-addrbook-expand-address) + ("Reply-To:" . wl-addrbook-expand-address)) + "*expansion function alist concerned with the key.") + +;;; Code: + +(defun wl-string-match-assoc (key alist &optional case-ignore) + (let (a + (case-fold-search case-ignore)) + (catch 'loop + (while alist + (setq a (car alist)) + (if (and (consp a) + (stringp (car a)) + (string-match key (car a))) + (throw 'loop a)) + (setq alist (cdr alist)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Low level functions +;;; + +(defsubst wl-draft-on-header-p () + (< (point) + (save-excursion + (goto-char (point-min)) + (search-forward (concat "\n" mail-header-separator "\n") nil 0) + (point)))) + +(defun wl-draft-on-value-p (switch) + (if (wl-draft-on-header-p) + (save-excursion + (beginning-of-line) + (while (and (< (point-min) (point)) (looking-at wl-complete-lwsp)) + (forward-line -1)) + (if (looking-at "\\([^:]*:\\)") + (wl-string-match-assoc (wl-match-buffer 1) switch t) + nil)))) ;; what a case reachs here? + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Completion function: C-i +;;; + +(defun wl-draft-addrbook-header-comp-or-tab (force) + (interactive "P") + (let ((case-fold-search t) + func) + (if (wl-draft-on-field-p) + (wl-complete-field) + (if (and + (wl-draft-on-header-p) + (setq func (wl-draft-on-value-p wl-field-completion-switch))) + (funcall (cdr func)) + (indent-for-tab-command))))) + +(defun wl-complete-newsgroups () + (interactive) + (wl-complete-field-body wl-folder-newsgroups-hashtb)) + ;;(wl-address-complete-address wl-folder-newsgroups-hashtb)) + +(defun wl-complete-folder () + "Folder complete function for Fcc:." + (interactive) + (let ((word (wl-delete-backward-char))) + (if (null word) + (wl-complete-window-show (list "+" "%")) + (wl-complete word wl-folder-entity-hashtb "folder" nil)))) + +(defun wl-addrbook-complete-address () + "Complete and expand address aliases. +First alias key is completed. When completed solely or the @ character +is inserted before the cursor, the alias key is expanded to its value." + (interactive) + (let ((word (wl-delete-backward-char))) + (if (null word) + (tab-to-tab-stop) + (if (string-match "@." word) + (insert (or (wl-alias-next word) word)) + (wl-complete + word wl-addrbook-alist "alias" ?@ nil nil + (function wl-addrbook-alias-get) + (function wl-addrbook-alias-hit)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Circular completion: C-cC-i +;;; + +(defun wl-draft-circular-comp () + "Switch function for circular complete functions." + (interactive) + (let ((func (wl-draft-on-value-p wl-field-circular-completion-switch))) + (if func + (funcall (cdr func)) + (message "No circular completion here")))) + +(defun wl-circular-complete-domain () + "Circular completion of domains for To:, Cc:, etc. +If the @ character does not exist, the first value of +wl-mail-domain-list is inserted. If exists, the next value of +wl-mail-domain-list concerned with the string between @ and +the cursor is inserted." + (interactive) + (let ((word (wl-delete-backward-char "@"))) + (cond + ((equal word nil) ;; @ doesn't exist. + (if (null wl-mail-domain-list) + (message "For domain circular completion, set wl-mail-domain-list") + (insert "@") + (insert (car wl-mail-domain-list)) + (wl-complete-window-delete))) + ((equal word t) ;; just after @ + (if (null wl-mail-domain-list) + (message "For domain circular completion, set wl-mail-domain-list") + (insert (car wl-mail-domain-list)) + (wl-complete-window-delete))) + (t + ;; can't use wl-get-next since completion is necessary sometime. + (wl-complete + word + (wl-slide-pair wl-mail-domain-list) + "domain" + t)) ;; use cdr + ))) + +(defun wl-circular-complete (msg clist cname &optional here) + "General circular complete function to call wl-complete." + (interactive) + (let ((str (wl-delete-value here))) + (if (null str) + (if (car clist) + (insert (car clist)) + (message "For circular completion, set %s" cname)) + (wl-complete + str + (wl-slide-pair clist) + msg + t)))) ;; use cdr + +(defun wl-circular-complete-from () + "Circular complete function for From:." + (interactive) + (wl-circular-complete "from" wl-from-list "wl-from-list")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Expansion : M-C-i +;;; + +(defun wl-draft-addrbook-expand () + "Switch function for expand functions." + (interactive) + (let ((func (wl-draft-on-value-p wl-field-expansion-switch))) + (if func + (funcall (cdr func)) + (message "No expansion here")))) + +(defun wl-addrbook-expand-address () + "Address expansion fuction for To:, Cc:, etc. +\"user@domain\" will be expands \"name \" if +the name exists." + (interactive) + (let ((word (wl-delete-backward-char)) name) + (if (null word) + (message "No address here") + (setq name (wl-addrbook-name-get word)) + (insert + (if name (format "%s <%s>" name word) word))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Hart function for completions +;;; + +(defun-maybe characterp (form) + (numberp form)) + +(eval-and-compile + (fset 'wl-complete-hit (symbol-function 'assoc))) + +(defun wl-complete-get (key alist) + (cdr (wl-complete-hit key alist))) + +(defun wl-complete (WORD ALIST MSG EXPAND-CHAR &optional TRY ALL GET HIT) + (let* ((ftry (or TRY (function try-completion))) + (fall (or ALL (function all-completions))) + (fget (or GET (function wl-complete-get))) + (fhit (or HIT (function wl-complete-hit))) + (cmp (funcall ftry WORD ALIST)) + (all (funcall fall WORD ALIST)) + (len (length WORD)) + subkey) + (cond + ;; already completed + ((eq cmp t) + (if EXPAND-CHAR ;; may be "t" + (insert (funcall fget WORD ALIST)) ;; use cdr + (insert WORD)) ;; use car + (wl-complete-window-delete)) + ;; EXPAND + ((and (characterp EXPAND-CHAR) + (char-equal (aref WORD (1- len)) EXPAND-CHAR) + (setq subkey (substring WORD 0 (1- len))) + (funcall fhit subkey ALIST)) + (insert (funcall fget subkey ALIST)) ;; use cdr + (wl-complete-window-delete)) + ;; just one candidate + ((equal 1 (length all)) + (insert cmp) + (wl-complete-window-delete) + (if (window-minibuffer-p (get-buffer-window (current-buffer))) + (wl-complete-temp-minibuffer-message " [Sole completion]") + (message "Sole completion"))) + ;; two or more candidates + ((stringp cmp) ;; (length all) > 1 + (insert cmp) + (wl-complete-window-show all) + (if (and EXPAND-CHAR (funcall fhit cmp ALIST)) + (message + (substitute-command-keys + "To expand %s, type %c then '\\\\[wl-draft-addrbook-header-comp-or-tab]'.") + cmp EXPAND-CHAR))) + ;; no candidate + (t + (insert WORD) + (if (window-minibuffer-p (get-buffer-window (current-buffer))) + (wl-complete-temp-minibuffer-message (concat " No matching " MSG)) + (message "No matching %s" MSG)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Minibuf magic +;;; + +(defun wl-complete-temp-minibuffer-message (m) + (let ((savemax (point-max))) + (save-excursion + (goto-char (point-max)) + (insert m)) + (let ((inhibit-quit t)) + (sit-for 2) + (delete-region savemax (point-max)) + (if quit-flag (setq quit-flag nil unread-command-events 7))))) + +;; +;; Extracting completion key +;; + +(defun wl-delete-backward-char (&optional here) + "Delete appropriate preceeding word and return it." + (interactive) + (let ((case-fold-search t) + (start nil) + (end (point)) + (regex (concat "[^" wl-complete-address-separator "]"))) + (save-excursion + (while (and (not (bobp)) + (string-match regex (buffer-substring-no-properties + (1- (point)) (point)))) + (forward-char -1)) + (if (and here (not (re-search-forward (regexp-quote here) end t))) + nil ;; "here" doesn't exist. + (setq start (point)) + (if (= start end) + (if here t nil) ;; just after "here", just after separator + (prog1 + (buffer-substring-no-properties start end) + (delete-region start end))))))) + +(defun wl-delete-value (&optional here) + (beginning-of-line) + (if (not (looking-at "[^:]+:")) + () + (goto-char (match-end 0)) + (if (looking-at "[ \t]") + (forward-char 1) + (insert " ")) + (if (eolp) + nil + (let ((start (point)) ret) + (end-of-line) + (if (and here (re-search-backward (regexp-quote here) start t)) + (progn + (setq start (1+ (point))) + (end-of-line))) + (setq ret (buffer-substring-no-properties start (point))) + (delete-region start (point)) + ret)))) + +;; +;; Making alist +;; + +(defun wl-slide-pair (x) + (let ((ret nil) + (first (car x))) + (cond + ((eq x 0) nil) + ((eq x 1) (cons first first)) + (t + (while (cdr x) + (setq ret (cons (cons (nth 0 x) (nth 1 x)) ret)) + (setq x (cdr x))) + (setq ret (cons (cons (car x) first) ret)) + (nreverse ret))))) + +(provide 'wl-complete) + +;;; Copyright Notice: + +;; Copyright (C) 1997-2001 Mew developing team. +;; Copyright (C) 2001 Masahiro Murata +;; All rights reserved. + +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; 1. Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; 2. Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; 3. Neither the name of the team nor the names of its contributors +;; may be used to endorse or promote products derived from this software +;; without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' AND +;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE TEAM OR CONTRIBUTORS BE +;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN +;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; wl-complete.el ends here -- 1.7.10.4