X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=wl%2Fwl-address.el;h=d539d6b09acff68bd4889c6901f849a473c5acb4;hb=57f081e684a5f0a1de02c96bc61ec175784974bb;hp=68126abd2640274e5a8ce476b828107c547b446a;hpb=10a95fa561ec82f555499e359e703a69eaecbad5;p=elisp%2Fwanderlust.git diff --git a/wl/wl-address.el b/wl/wl-address.el index 68126ab..d539d6b 100644 --- a/wl/wl-address.el +++ b/wl/wl-address.el @@ -1,11 +1,12 @@ -;;; wl-address.el -- Tiny address management for Wanderlust. +;;; wl-address.el --- Tiny address management for Wanderlust. + +;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi +;; Copyright (C) 1998,1999,2000 Shun-ichi GOTO +;; Copyright (C) 1998,1999,2000 Takeshi Chiba -;; Copyright 1998,1999,2000 Yuuichi Teranishi -;; Shun-ichi GOTO -;; Takeshi Chiba ;; Author: Yuuichi Teranishi -;; Shun-ichi GOTO -;; Takeshi Chiba +;; Shun-ichi GOTO +;; Takeshi Chiba ;; Keywords: mail, net news ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen). @@ -27,21 +28,25 @@ ;; ;;; Commentary: -;; +;; ;;; Code: -;; +;; (require 'wl-util) (require 'wl-vars) (require 'std11) -(defvar wl-address-complete-header-regexp "^\\(To\\|From\\|Cc\\|Bcc\\|Mail-Followup-To\\|Reply-To\\|Return-Receipt-To\\):") +(defvar wl-address-complete-header-list + '("To:" "From:" "Cc:" "Bcc:" "Mail-Followup-To:" "Reply-To:" + "Return-Receipt-To:")) +(defvar wl-address-complete-header-regexp nil) ; auto-generated. (defvar wl-newsgroups-complete-header-regexp "^\\(Newsgroups\\|Followup-To\\):") -(defvar wl-folder-complete-header-regexp "^\\(FCC\\):") +(defvar wl-folder-complete-header-regexp "^\\(Fcc\\):") (defvar wl-address-list nil) (defvar wl-address-completion-list nil) (defvar wl-address-petname-hash nil) +(defvar wl-address-enable-strict-loading t) (defvar wl-address-ldap-search-hash nil) @@ -82,7 +87,7 @@ If level 3 is required for uniqness with other candidates, (defconst wl-ldap-alias-sep "/") (defconst wl-ldap-search-attribute-type-list - '("sn" "cn" "mail")) + '("sn" "cn" "mail" "email")) (defun wl-ldap-get-value (type entry) "" @@ -95,7 +100,7 @@ If level 3 is required for uniqness with other candidates, values nil) (setq values (cdr values))))) ret)) - + (defun wl-ldap-get-value-list (type entry) "" (cdr (assoc type entry))) @@ -103,11 +108,11 @@ If level 3 is required for uniqness with other candidates, (defun wl-ldap-make-filter (pat type-list) "Make RFC1558 quiery filter for PAT from ATTR-LIST. Each are \"OR\" combination, and PAT is beginning-match." - (concat "(&(objectclass=person)(|" + (concat "(|" (mapconcat (lambda (x) (format "(%s=%s*)" x pat)) ; fixed format type-list "") - "))")) + ")")) (defun wl-ldap-make-matched-value-list (regexp type-list entry) "Correct matching WORD with value of TYPE-LIST in ENTRY. @@ -118,9 +123,8 @@ Returns matched uniq string list." (setq type (car (car entry)) values (mapcar (function wl-ldap-alias-safe-string) (cdr (car entry))) + values (elmo-flatten values) entry (cdr entry)) - (if (string-match "::?$" type) - (setq type (substring type 0 (match-beginning 0)))) (if (member type type-list) (while values (setq val (car values) @@ -133,15 +137,13 @@ Returns matched uniq string list." (defun wl-ldap-alias-safe-string (str) "Modify STR for alias. Replace space/tab in STR into '_' char. -Replace '@' in STR into '/' char." - (while (string-match "[^_a-zA-Z0-9+@%.!\\-/]+" str) +Replace '@' in STR into list of mailbox and sub-domains." + (while (string-match "[ \t]+" str) (setq str (concat (substring str 0 (match-beginning 0)) "_" (substring str (match-end 0))))) (if (string-match "\\(@\\)[^/@]+" str) - (setq str (concat (substring str 0 (match-beginning 1)) - "/" - (substring str (match-end 1))))) + (setq str (split-string str "[@\\.]"))) str) (defun wl-ldap-register-dn-string (hash dn &optional str dn-list) @@ -157,7 +159,8 @@ Replace '@' in STR into '/' char." (if (string-match "[a-z]+=\\(.*\\)" str) (wl-ldap-alias-safe-string (wl-match-string 1 str)))) - (split-string dn ","))))) + (split-string dn "[ \t]*,[ \t]*"))))) + (setq dn-list (elmo-flatten dn-list)) ;; prepare candidate for uniq str (if str (setq str (concat str wl-ldap-alias-sep (car dn-list)) @@ -199,9 +202,9 @@ Matched address lists are append to CL." (let ((pat (if (string-match wl-ldap-alias-sep pattern) (substring pattern 0 (match-beginning 0)) pattern)) - (ldap-default-host wl-ldap-server) - (ldap-default-port (or wl-ldap-port 389)) - (ldap-default-base wl-ldap-base) + (ldap-default-host (or wl-ldap-server ldap-default-host "localhost")) + (ldap-default-port (or wl-ldap-port ldap-default-port 389)) + (ldap-default-base (or wl-ldap-base ldap-default-base)) (dnhash (elmo-make-hash)) cache len sym tmpl regexp entries ent values dn dnstr alias result cn mails) @@ -219,17 +222,14 @@ Matched address lists are append to CL." ;; get matched entries (if cache (setq entries (cdr cache)) - (condition-case nil - (progn - (message "Searching in LDAP...") - (setq entries (ldap-search-entries - (wl-ldap-make-filter - (concat pat "*") - wl-ldap-search-attribute-type-list) - nil wl-ldap-search-attribute-type-list nil t)) - (message "Searching in LDAP...done") - (elmo-set-hash-val pattern entries wl-address-ldap-search-hash)) - (error (message "")))) ; ignore error: No such object + (ignore-errors + (message "Searching in LDAP...") + (setq entries (ldap-search-entries + (wl-ldap-make-filter + pat wl-ldap-search-attribute-type-list) + nil wl-ldap-search-attribute-type-list nil t)) + (message "Searching in LDAP...done") + (elmo-set-hash-val pattern entries wl-address-ldap-search-hash))) ;; (setq tmpl entries) (while tmpl @@ -240,8 +240,10 @@ Matched address lists are append to CL." (while entries (setq ent (cdar entries) values (wl-ldap-make-matched-value-list - regexp '("mail" "sn" "cn") ent) - mails (wl-ldap-get-value-list "mail" ent) + regexp wl-ldap-search-attribute-type-list + ent) + mails (or (wl-ldap-get-value-list "mail" ent) + (wl-ldap-get-value-list "email" ent)) cn (wl-ldap-get-value "cn" ent) dn (car (car entries)) dnstr (elmo-get-hash-val (upcase dn) dnhash)) @@ -272,44 +274,54 @@ Matched address lists are append to CL." (setq entries (cdr entries))) (append result cl))) -(defun wl-complete-field-to () - (interactive) - (let ((cl wl-address-completion-list)) - (if cl - (completing-read "To: " cl) - (read-string "To: ")))) - -(defun wl-address-quote-specials (word) - "Make quoted string of WORD if needed." - (if (assq 'specials (std11-lexical-analyze word)) - (prin1-to-string word) - word)) +(defun wl-complete-address (string predicate flag) + "Completion function for completing-read (comma separated addresses)." + (if (string-match "^\\(.*,\\)\\(.*\\)$" string) + (let* ((str1 (match-string 1 string)) + (str2 (match-string 2 string)) + (str2-comp (wl-complete-address str2 predicate flag))) + (if (and (not flag) (stringp str2-comp)) + (concat str1 str2-comp) + str2-comp)) + (if (not flag) + (try-completion string wl-address-list) + (all-completions string wl-address-list)))) + +(defalias 'wl-address-quote-specials 'elmo-address-quote-specials) (defun wl-address-make-completion-list (address-list) (let (addr-tuple cl) (while address-list (setq addr-tuple (car address-list)) (setq cl - (cons - (cons (nth 0 addr-tuple) - (concat - (wl-address-quote-specials - (nth 2 addr-tuple)) " <"(nth 0 addr-tuple)">")) - cl)) + (cons + (wl-address-make-completion-entry 0 addr-tuple) + cl)) ;; nickname completion. - (unless (or (equal (nth 1 addr-tuple) (nth 0 addr-tuple)) - ;; already exists - (assoc (nth 1 addr-tuple) cl)) + (if wl-address-enable-strict-loading + (unless (or (equal (nth 1 addr-tuple) (nth 0 addr-tuple)) + ;; already exists + (assoc (nth 1 addr-tuple) cl)) + (setq cl + (cons + (wl-address-make-completion-entry 1 addr-tuple) + cl))) (setq cl (cons - (cons (nth 1 addr-tuple) - (concat - (wl-address-quote-specials - (nth 2 addr-tuple)) " <"(nth 0 addr-tuple)">")) + (wl-address-make-completion-entry 1 addr-tuple) cl))) (setq address-list (cdr address-list))) cl)) +(defun wl-address-make-completion-entry (index addr-tuple) + (cons (nth index addr-tuple) + (if (or (string= (nth 2 addr-tuple) "") + (string-match ".*:.*;$" (nth 0 addr-tuple))) + (nth 0 addr-tuple) + (concat + (wl-address-quote-specials + (nth 2 addr-tuple)) " <"(nth 0 addr-tuple)">")))) + (defun wl-complete-field-body-or-tab () (interactive) (let ((case-fold-search t) @@ -362,7 +374,7 @@ Matched address lists are append to CL." (with-output-to-temp-buffer wl-completion-buf-name (display-completion-list all)) - (message "Making completion list... done"))) + (message "Making completion list...done"))) (defun wl-complete-window-delete () (let (comp-buf comp-win) @@ -382,8 +394,8 @@ Matched address lists are append to CL." (if (null cl) nil (setq completion - (let ((completion-ignore-case t)) - (try-completion pattern cl))) + (let ((completion-ignore-case t)) + (try-completion pattern cl))) (cond ((eq completion t) (let ((alias (assoc pattern cl))) (if alias @@ -428,6 +440,7 @@ Matched address lists are append to CL." (completion) (pattern (buffer-substring start end)) (len (length pattern)) + (completion-ignore-case t) (cl completion-list)) (when use-ldap (setq cl (wl-address-ldap-search pattern cl))) @@ -441,7 +454,8 @@ Matched address lists are append to CL." (message "Sole completion")) ((and epand-char (> len 0) - (char-equal (aref pattern (1- len)) epand-char) + (or (char-equal (aref pattern (1- len)) epand-char) + (char-equal (aref pattern (1- len)) ?\ )) (assoc (substring pattern 0 (1- len)) cl)) (wl-complete-insert start end @@ -457,11 +471,11 @@ Matched address lists are append to CL." (let ((list (sort (all-completions pattern cl) 'string<))) (wl-complete-window-show list))))))) -(defvar wl-address-init-func 'wl-local-address-init) +(defvar wl-address-init-function 'wl-local-address-init) (defun wl-address-init () - "Call `wl-address-init-func'." - (funcall wl-address-init-func)) + "Call `wl-address-init-function'." + (funcall wl-address-init-function)) (defun wl-local-address-init () "Reload `wl-address-file'. @@ -490,24 +504,24 @@ Refresh `wl-address-list', `wl-address-completion-list', and (when (< nest-count 5) (let (expn-str new-expn-str expn new-expn(n 0) (expanded nil)) (while (setq expn-str (cdr (nth n alist))) - (setq new-expn-str nil) - (while (string-match "^[ \t]*\\([^,]+\\)" expn-str) - (setq expn (elmo-match-string 1 expn-str)) + (setq new-expn-str nil) + (while (string-match "^[ \t]*\\([^,]+\\)" expn-str) + (setq expn (elmo-match-string 1 expn-str)) (setq expn-str (wl-string-delete-match expn-str 0)) - (if (string-match "^[ \t,]+" expn-str) + (if (string-match "^[ \t,]+" expn-str) (setq expn-str (wl-string-delete-match expn-str 0))) - (if (string-match "[ \t,]+$" expn) + (if (string-match "[ \t,]+$" expn) (setq expn (wl-string-delete-match expn 0))) - (setq new-expn (cdr (assoc expn alist))) - (if new-expn - (setq expanded t)) - (setq new-expn-str (concat new-expn-str (and new-expn-str ", ") - (or new-expn expn)))) - (when new-expn-str - (setcdr (nth n alist) new-expn-str)) - (setq n (1+ n))) + (setq new-expn (cdr (assoc expn alist))) + (if new-expn + (setq expanded t)) + (setq new-expn-str (concat new-expn-str (and new-expn-str ", ") + (or new-expn expn)))) + (when new-expn-str + (setcdr (nth n alist) new-expn-str)) + (setq n (1+ n))) (and expanded - (wl-address-expand-aliases alist (1+ nest-count)))))) + (wl-address-expand-aliases alist (1+ nest-count)))))) (defun wl-address-make-alist-from-alias-file (file) (elmo-set-work-buf @@ -517,7 +531,7 @@ Refresh `wl-address-list', `wl-address-completion-list', and (while (re-search-forward ",$" nil t) (end-of-line) (forward-char 1) - (delete-backward-char 1)) + (delete-backward-char 1)) (goto-char (point-min)) (while (re-search-forward "^\\([^#;\n][^:]+\\):[ \t]*\\(.*\\)$" nil t) (setq alias (wl-match-buffer 1) @@ -526,41 +540,26 @@ Refresh `wl-address-list', `wl-address-completion-list', and (wl-address-expand-aliases alist 0) (nreverse alist) ; return value ))) - + (defun wl-address-make-address-list (path) (if (and path (file-readable-p path)) (elmo-set-work-buf - (let (ret - (coding-system-for-read wl-cs-autoconv)) - (insert-file-contents path) - (goto-char (point-min)) - (while (not (eobp)) - (if (looking-at - "^\\([^#\n][^ \t\n]+\\)[ \t]+\"\\(.*\\)\"[ \t]+\"\\(.*\\)\"[ \t]*.*$") - (setq ret - (wl-append-element - ret - (list (wl-match-buffer 1) - (wl-match-buffer 2) - (wl-match-buffer 3))))) - (forward-line)) - ret)))) - -(defsubst wl-address-get-petname-1 (string) - (let ((address (downcase (wl-address-header-extract-address string)))) - (elmo-get-hash-val address wl-address-petname-hash))) + (let (ret + (coding-system-for-read wl-cs-autoconv)) + (insert-file-contents path) + (goto-char (point-min)) + (while (not (eobp)) + (if (looking-at + "^\\([^#\n][^ \t\n]+\\)[ \t]+\\(\".*\"\\)[ \t]+\\(\".*\"\\)[ \t]*.*$") + (setq ret + (cons + (list (wl-match-buffer 1) + (read (wl-match-buffer 2)) + (read (wl-match-buffer 3))) + ret))) + (forward-line)) + (nreverse ret))))) -(defsubst wl-address-get-petname (string) - (or (wl-address-get-petname-1 string) - string)) - -(defsubst wl-address-user-mail-address-p (address) - "Judge whether ADDRESS is user's or not." - (member (downcase (wl-address-header-extract-address address)) - (or (mapcar 'downcase wl-user-mail-address-list) - (list (downcase - (wl-address-header-extract-address - wl-from)))))) (defsubst wl-address-header-extract-address (str) "Extracts a real e-mail address from STR and return it. @@ -569,18 +568,56 @@ e.g. \"Mine Sakurai \" e.g. \"m-sakura@ccs.mt.nec.co.jp (Mine Sakurai)\" -> \"m-sakura@ccs.mt.nec.co.jp\"." (cond ((string-match ".*<\\([^>]*\\)>" str) ; .* to extract last <> - (wl-match-string 1 str)) - ((string-match "\\([^ \t\n]*@[^ \t\n]*\\)" str) (wl-match-string 1 str)) - (t str))) + ((string-match "\\([^ \t\n]*@[^ \t\n]*\\)" str) + (wl-match-string 1 str)) + (t str))) (defsubst wl-address-header-extract-realname (str) "Extracts a real name from STR and return it. e.g. \"Mr. bar \" -> \"Mr. bar\"." (cond ((string-match "\\(.*[^ \t]\\)[ \t]*<[^>]*>" str) - (wl-match-string 1 str)) - (t ""))) + (wl-match-string 1 str)) + (t ""))) + + +(defun wl-address-get-petname-1 (string) + (let ((address (downcase (wl-address-header-extract-address string)))) + (elmo-get-hash-val address wl-address-petname-hash))) + +(defsubst wl-address-get-petname (string) + (or (wl-address-get-petname-1 string) + string)) + +(defun wl-address-user-mail-address-p (address) + "Judge whether ADDRESS is user's or not." + (if wl-user-mail-address-regexp + (string-match wl-user-mail-address-regexp + (wl-address-header-extract-address address)) + (member (downcase (wl-address-header-extract-address address)) + (or (mapcar 'downcase wl-user-mail-address-list) + (list (downcase + (wl-address-header-extract-address + wl-from))))))) + +(defun wl-address-delete-user-mail-addresses (address-list) + "Delete user mail addresses from list by side effect. +Deletion is done by using `elmo-list-delete'." + (if wl-user-mail-address-regexp + (elmo-list-delete (list wl-user-mail-address-regexp) address-list + (lambda (elem list) + (elmo-delete-if + (lambda (item) (string-match elem item)) + list))) + (let ((myself (or wl-user-mail-address-list + (list (wl-address-header-extract-address wl-from))))) + (elmo-list-delete myself address-list + (lambda (elem list) + (elmo-delete-if + (lambda (item) (string= (downcase elem) + (downcase item))) + list)))))) (defmacro wl-address-concat-token (string token) (` (cond @@ -627,70 +664,99 @@ Group list contents is not included." (setq sequence (cdr sequence))))) address-string)) -(defun wl-address-petname-delete (the-email) - "Delete petname in `wl-address-file'." - (let* ( (tmp-buf (get-buffer-create " *wl-petname-tmp*")) - (output-coding-system - (mime-charset-to-coding-system wl-mime-charset))) - (set-buffer tmp-buf) - (message "Deleting Petname...") - (erase-buffer) - (insert-file-contents wl-address-file) - (delete-matching-lines (concat "^[ \t]*" the-email)) - (write-region (point-min) (point-max) - wl-address-file nil 'no-msg) - (message "Deleting Petname...done") - (kill-buffer tmp-buf))) - - -(defun wl-address-petname-add-or-change (the-email - default-petname - default-realname - &optional change-petname) - "Add petname to `wl-address-file', if not registerd. +(defun wl-address-delete (the-email) + "Delete address entry in the `wl-address-file'." + (let ((output-coding-system + (mime-charset-to-coding-system wl-mime-charset))) + (with-temp-buffer + (message "Deleting Address...") + (insert-file-contents wl-address-file) + (delete-matching-lines (concat "^[ \t]*" the-email "[ \t]+\".*\"[ \t]+\".*\"$")) + (write-region (point-min) (point-max) + wl-address-file nil 'no-msg) + ;; Delete entries. + (dolist (entry (elmo-string-assoc-all the-email wl-address-list)) + (setq wl-address-list (delete entry wl-address-list))) + (elmo-set-hash-val the-email nil wl-address-petname-hash) + (message "Deleting Address...done")))) + +(defun wl-address-add-or-change (address + &optional default-realname + change-address) + "Add address entry to `wl-address-file', if not registerd. If already registerd, change it." - (let (the-realname the-petname) - - ;; setup output "petname" - ;; if null petname'd, let default-petname be the petname. - (setq the-petname - (read-from-minibuffer (format "Petname: ") default-petname)) - (if (string= the-petname "") - (setq the-petname (or default-petname the-email))) - - ;; setup output "realname" + (let ((entry (assoc address wl-address-list)) + the-realname the-petname new-addr addr-changed) (setq the-realname - (read-from-minibuffer (format "Real Name: ") default-realname)) -;;; (if (string= the-realname "") -;;; (setq the-realname default-petname)) - + (read-from-minibuffer "Real Name: " (or default-realname + (nth 2 entry)))) + (setq the-petname (read-from-minibuffer "Petname: " + (or (nth 1 entry) + the-realname))) + (when change-address + (setq new-addr (read-from-minibuffer "E-Mail: " address)) + (cond + ((or (not (stringp new-addr)) + (string-match "^[ \t]*$" new-addr)) + (error "empty address")) + ((and (not (string= address new-addr)) + (assoc new-addr wl-address-list)) + (error "'%s' already exists" new-addr)) + (t + ;; do nothing + ))) ;; writing to ~/.address - (let ( (tmp-buf (get-buffer-create " *wl-petname-tmp*")) - (output-coding-system (mime-charset-to-coding-system wl-mime-charset))) - (set-buffer tmp-buf) - (message "Adding Petname...") - (erase-buffer) - (if (file-exists-p wl-address-file) - (insert-file-contents wl-address-file)) - (if (not change-petname) - ;; if only add - (progn - (goto-char (point-max)) - (if (and (> (buffer-size) 0) - (not (eq (char-after (1- (point-max))) ?\n))) - (insert "\n"))) - ;; if change - (if (re-search-forward (concat "^[ \t]*" the-email) nil t) + (let ((output-coding-system + (mime-charset-to-coding-system wl-mime-charset))) + (with-temp-buffer + (if (file-exists-p wl-address-file) + (insert-file-contents wl-address-file)) + (if (null entry) + ;; add + (progn + (goto-char (point-max)) + (if (and (> (buffer-size) 0) + (not (eq (char-after (1- (point-max))) ?\n))) + (insert "\n"))) + ;; override + (while (re-search-forward (concat "^[ \t]*" address) nil t) (delete-region (save-excursion (beginning-of-line) (point)) (save-excursion (end-of-line) (+ 1 (point)))))) - (insert (format "%s\t\"%s\"\t\"%s\"\n" - the-email the-petname the-realname)) - (write-region (point-min) (point-max) - wl-address-file nil 'no-msg) - (message "Adding Petname...done") - (kill-buffer tmp-buf)))) + (insert (format "%s\t%s\t%s\n" + (or new-addr address) + (prin1-to-string the-petname) + (prin1-to-string the-realname))) + (write-region (point-min) (point-max) + wl-address-file nil 'no-msg) + (wl-address-init) + (list (or new-addr address) the-petname the-realname))))) + +;; Read addresses from minibuffer with completion. +(defvar wl-address-minibuffer-history nil) +(defvar wl-address-minibuffer-local-map nil + "Keymap to use when reading address from the minibuffer.") + +(unless wl-address-minibuffer-local-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map minibuffer-local-map) + (define-key map "\C-i" + (lambda () + (interactive) + (wl-complete-field-body wl-address-completion-list + ?@ nil wl-use-ldap))) + (setq wl-address-minibuffer-local-map map))) + +(defun wl-address-read-from-minibuffer (prompt &optional + initial-contents + default-value) + (read-from-minibuffer prompt + initial-contents + wl-address-minibuffer-local-map + nil + 'wl-address-minibuffer-history + default-value)) (require 'product) (product-provide (provide 'wl-address) (require 'wl-version))