X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=wl%2Fwl-address.el;h=d41537d861b093de2d115c0183271003c29ae6ef;hb=0dde8858aebea5d441e0156d7649f766706d45d7;hp=52e1ee23b2f9e31c5799191c8fe570a60dc80551;hpb=8b003dd16e3d4a1f0d29b5fcd0f57a2ee294f967;p=elisp%2Fwanderlust.git diff --git a/wl/wl-address.el b/wl/wl-address.el index 52e1ee2..d41537d 100644 --- a/wl/wl-address.el +++ b/wl/wl-address.el @@ -1,4 +1,4 @@ -;;; 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 @@ -28,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) @@ -83,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) "" @@ -96,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))) @@ -104,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. @@ -121,8 +125,6 @@ Returns matched uniq string list." (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) @@ -136,7 +138,7 @@ Returns matched uniq string list." "Modify STR for alias. Replace space/tab in STR into '_' char. Replace '@' in STR into list of mailbox and sub-domains." - (while (string-match "[^_a-zA-Z0-9+@%.!\\-/]+" str) + (while (string-match "[ \t]+" str) (setq str (concat (substring str 0 (match-beginning 0)) "_" (substring str (match-end 0))))) @@ -200,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) @@ -220,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 @@ -241,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)) @@ -273,46 +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: ")))) - -(defconst wl-address-specials-regexp "[]\"(),.:;<>@[\\]") - -(defun wl-address-quote-specials (word) - "Make quoted string of WORD if needed." - (if (string-match wl-address-specials-regexp 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) @@ -365,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) @@ -385,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 @@ -431,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))) @@ -444,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 @@ -493,34 +504,34 @@ 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 + (with-temp-buffer (let ((case-fold-search t) alias expn alist) (insert-file-contents file) (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) @@ -529,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)))) - -(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-make-address-list (path) + (when (and path (file-readable-p path)) + (with-temp-buffer + (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-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. @@ -572,27 +568,65 @@ 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 - ((eq 'quoted-string (car (, token))) - (concat (, string) "\"" (cdr (, token)) "\"")) - ((eq 'comment (car (, token))) - (concat (, string) "(" (cdr (, token)) ")")) - (t - (concat (, string) (cdr (, token))))))) + `(cond + ((eq 'quoted-string (car ,token)) + (concat ,string "\"" (cdr ,token) "\"")) + ((eq 'comment (car ,token)) + (concat ,string "(" (cdr ,token) ")")) + (t + (concat ,string (cdr ,token))))) (defun wl-address-string-without-group-list-contents (sequence) "Return address string from lexical analyzed list SEQUENCE. @@ -630,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))