/[emacs]/emacs/lisp/mh-e/mh-alias.el
ViewVC logotype

Diff of /emacs/lisp/mh-e/mh-alias.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.3.4.2 by miles, Tue Oct 14 23:39:25 2003 UTC revision 1.3.4.3 by miles, Sat Jul 17 02:51:48 2004 UTC
# Line 1  Line 1 
1  ;;; mh-alias.el --- MH-E mail alias completion and expansion  ;;; mh-alias.el --- MH-E mail alias completion and expansion
2  ;;  ;;
3  ;; Copyright (C) 1994, 95, 96, 1997,  ;; Copyright (C) 1994, 95, 96, 1997,
4  ;;  2001, 02, 2003 Free Software Foundation, Inc.  ;;  2001, 02, 03, 2004 Free Software Foundation, Inc.
5    
6  ;; Author: Peter S. Galbraith <psg@debian.org>  ;; Author: Peter S. Galbraith <psg@debian.org>
7  ;; Maintainer: Bill Wohler <wohler@newt.com>  ;; Maintainer: Bill Wohler <wohler@newt.com>
# Line 128  Line 128 
128    
129  ;;; Alias Loading  ;;; Alias Loading
130    
131    (defmacro mh-assoc-ignore-case (key alist)
132      "Search for string KEY in ALIST.
133    This is a wrapper around `assoc-string' or `assoc-ignore-case'. Avoid
134    `assoc-ignore-case' which is now an obsolete function."
135      (cond ((fboundp 'assoc-string) `(assoc-string ,key ,alist t))
136            ((fboundp 'assoc-ignore-case) `(assoc-ignore-case ,key ,alist))
137            (t (error "The macro mh-assoc-ignore-case not implemented properly"))))
138    
139  (defun mh-alias-tstamp (arg)  (defun mh-alias-tstamp (arg)
140    "Check whether alias files have been modified.    "Check whether alias files have been modified.
141  Return t if any file listed in the MH profile component Aliasfile has been  Return t if any file listed in the MH profile component Aliasfile has been
# Line 169  If ARG is non-nil, filenames listed in ` Line 177  If ARG is non-nil, filenames listed in `
177              (append userlist mh-alias-system-aliases))              (append userlist mh-alias-system-aliases))
178          userlist))))          userlist))))
179    
180    (defun mh-alias-gecos-name (gecos-name username comma-separator)
181      "Return a usable address string from a GECOS-NAME and USERNAME.
182    Use only part of the GECOS-NAME up to the first comma if COMMA-SEPARATOR is
183    non-nil."
184      (let ((res gecos-name))
185        ;; Keep only string until first comma if COMMA-SEPARATOR is t.
186        (if (and comma-separator
187                 (string-match "^\\([^,]+\\)," res))
188            (setq res (match-string 1 res)))
189        ;; Replace "&" with capitalized username
190        (if (string-match "&" res)
191            (setq res (mh-replace-in-string "&" (capitalize username) res)))
192        ;; Remove " character
193        (if (string-match "\"" res)
194            (setq res (mh-replace-in-string "\"" "" res)))
195        ;; If empty string, use username instead
196        (if (string-equal "" res)
197            (setq res username))
198        ;; Surround by quotes if doesn't consist of simple characters
199        (if (not (string-match "^[ a-zA-Z0-9-]+$" res))
200            (setq res (concat "\"" res "\"")))
201        res))
202    
203  (defun mh-alias-local-users ()  (defun mh-alias-local-users ()
204    "Return an alist of local users from /etc/passwd."    "Return an alist of local users from /etc/passwd."
205    (let (passwd-alist)    (let (passwd-alist)
# Line 185  If ARG is non-nil, filenames listed in ` Line 216  If ARG is non-nil, filenames listed in `
216          (goto-char (point-min))))          (goto-char (point-min))))
217        (while  (< (point) (point-max))        (while  (< (point) (point-max))
218          (cond          (cond
219           ((looking-at "\\([^:]*\\):[^:]*:\\([^:]*\\):[^:]*:\\([^:,]*\\)[:,]")           ((looking-at "\\([^:]*\\):[^:]*:\\([^:]*\\):[^:]*:\\([^:]*\\):")
220            (when (> (string-to-int (match-string 2)) 200)            (when (> (string-to-int (match-string 2)) 200)
221              (let* ((username (match-string 1))              (let* ((username (match-string 1))
222                     (gecos-name (match-string 3))                     (gecos-name (match-string 3))
223                     (realname                     (realname (mh-alias-gecos-name
224                      (if (string-match "&" gecos-name)                                gecos-name username
225                          (concat                                mh-alias-passwd-gecos-comma-separator-flag)))
                          (substring gecos-name 0 (match-beginning 0))  
                          (capitalize username)  
                          (substring gecos-name (match-end 0)))  
                       gecos-name)))  
226                (setq passwd-alist                (setq passwd-alist
227                      (cons (list username                      (cons
228                                  (if (string-equal "" realname)                       (list (if mh-alias-local-users-prefix
229                                      (concat "<" username ">")                                 (concat mh-alias-local-users-prefix
230                                    (concat realname " <" username ">")))                                         (mh-alias-suggest-alias realname t))
231                            passwd-alist))))))                               username)
232                               (if (string-equal username realname)
233                                   (concat "<" username ">")
234                                 (concat realname " <" username ">")))
235                         passwd-alist))))))
236          (forward-line 1)))          (forward-line 1)))
237      passwd-alist))      passwd-alist))
238    
# Line 219  If ARG is non-nil, filenames listed in ` Line 250  If ARG is non-nil, filenames listed in `
250        (cond        (cond
251         ((looking-at "^[ \t]"))          ;Continuation line         ((looking-at "^[ \t]"))          ;Continuation line
252         ((looking-at "\\(.+\\): .+: .*$") ; A new -blind- MH alias         ((looking-at "\\(.+\\): .+: .*$") ; A new -blind- MH alias
253          (when (not (assoc-ignore-case (match-string 1) mh-alias-blind-alist))          (when (not (mh-assoc-ignore-case (match-string 1) mh-alias-blind-alist))
254            (setq mh-alias-blind-alist            (setq mh-alias-blind-alist
255                  (cons (list (match-string 1)) mh-alias-blind-alist))                  (cons (list (match-string 1)) mh-alias-blind-alist))
256            (setq mh-alias-alist (cons (list (match-string 1)) mh-alias-alist))))            (setq mh-alias-alist (cons (list (match-string 1)) mh-alias-alist))))
257         ((looking-at "\\(.+\\): .*$")    ; A new MH alias         ((looking-at "\\(.+\\): .*$")    ; A new MH alias
258          (when (not (assoc-ignore-case (match-string 1) mh-alias-alist))          (when (not (mh-assoc-ignore-case (match-string 1) mh-alias-alist))
259            (setq mh-alias-alist            (setq mh-alias-alist
260                  (cons (list (match-string 1)) mh-alias-alist)))))                  (cons (list (match-string 1)) mh-alias-alist)))))
261        (forward-line 1)))        (forward-line 1)))
# Line 235  If ARG is non-nil, filenames listed in ` Line 266  If ARG is non-nil, filenames listed in `
266            user)            user)
267        (while local-users        (while local-users
268          (setq user (car local-users))          (setq user (car local-users))
269          (if (not (assoc-ignore-case (car user) mh-alias-alist))          (if (not (mh-assoc-ignore-case (car user) mh-alias-alist))
270              (setq mh-alias-alist (append mh-alias-alist (list user))))              (setq mh-alias-alist (append mh-alias-alist (list user))))
271          (setq local-users (cdr local-users)))))          (setq local-users (cdr local-users)))))
272    (message "Loading MH aliases...done"))    (message "Loading MH aliases...done"))
273    
274    ;;;###mh-autoload
275  (defun mh-alias-reload-maybe ()  (defun mh-alias-reload-maybe ()
276    "Load new MH aliases."    "Load new MH aliases."
277    (if (or (eq mh-alias-alist 'not-read) ; Doesn't exist, so create it.    (if (or (eq mh-alias-alist 'not-read) ; Doesn't exist, so create it.
# Line 269  ali returns the string unchanged if not Line 301  ali returns the string unchanged if not
301    "Return expansion for ALIAS.    "Return expansion for ALIAS.
302  Blind aliases or users from /etc/passwd are not expanded."  Blind aliases or users from /etc/passwd are not expanded."
303    (cond    (cond
304     ((assoc-ignore-case alias mh-alias-blind-alist)     ((mh-assoc-ignore-case alias mh-alias-blind-alist)
305      alias)                              ; Don't expand a blind alias      alias)                              ; Don't expand a blind alias
306     ((assoc-ignore-case alias mh-alias-passwd-alist)     ((mh-assoc-ignore-case alias mh-alias-passwd-alist)
307      (cadr (assoc-ignore-case alias mh-alias-passwd-alist)))      (cadr (mh-assoc-ignore-case alias mh-alias-passwd-alist)))
308     (t     (t
309      (mh-alias-ali alias))))      (mh-alias-ali alias))))
310    
# Line 302  Blind aliases or users from /etc/passwd Line 334  Blind aliases or users from /etc/passwd
334  (defun mh-alias-minibuffer-confirm-address ()  (defun mh-alias-minibuffer-confirm-address ()
335    "Display the alias expansion if `mh-alias-flash-on-comma' is non-nil."    "Display the alias expansion if `mh-alias-flash-on-comma' is non-nil."
336    (interactive)    (interactive)
337    (if (not mh-alias-flash-on-comma)    (when mh-alias-flash-on-comma
       ()  
338      (save-excursion      (save-excursion
339        (let* ((case-fold-search t)        (let* ((case-fold-search t)
340               (the-name (buffer-substring               (beg (mh-beginning-of-word))
341                          (progn (skip-chars-backward " \t")(point))               (the-name (buffer-substring-no-properties beg (point))))
342                          ;; This moves over to previous comma, if any          (if (mh-assoc-ignore-case the-name mh-alias-alist)
                         (progn (or (and (not (= 0 (skip-chars-backward "^,")))  
                                         ;; the skips over leading whitespace  
                                         (skip-chars-forward " "))  
                                    ;; no comma, then to beginning of word  
                                    (skip-chars-backward "^ \t"))  
                                ;; In Emacs21, the beginning of the prompt  
                                ;; line is accessible, which wasn't the case  
                                ;; in emacs20.  Skip over it.  
                                (if (looking-at "^[^ \t]+:")  
                                    (skip-chars-forward "^ \t"))  
                                (skip-chars-forward " ")  
                                (point)))))  
         (if (assoc-ignore-case the-name mh-alias-alist)  
343              (message "%s -> %s" the-name (mh-alias-expand the-name))              (message "%s -> %s" the-name (mh-alias-expand the-name))
344            ;; Check if if was a single word likely to be an alias            ;; Check if if was a single word likely to be an alias
345            (if (and (equal mh-alias-flash-on-comma 1)            (if (and (equal mh-alias-flash-on-comma 1)
# Line 335  Blind aliases or users from /etc/passwd Line 353  Blind aliases or users from /etc/passwd
353  (defun mh-alias-letter-expand-alias ()  (defun mh-alias-letter-expand-alias ()
354    "Expand mail alias before point."    "Expand mail alias before point."
355    (mh-alias-reload-maybe)    (mh-alias-reload-maybe)
356    (let ((mail-abbrevs mh-alias-alist))    (let* ((end (point))
357      (mh-funcall-if-exists mail-abbrev-complete-alias))           (begin (mh-beginning-of-word))
358    (when mh-alias-expand-aliases-flag           (input (buffer-substring-no-properties begin end)))
359      (let* ((end (point))      (mh-complete-word input mh-alias-alist begin end)
360             (syntax-table (syntax-table))      (when mh-alias-expand-aliases-flag
361             (beg (unwind-protect        (let* ((end (point))
362                      (save-excursion               (expansion (mh-alias-expand (buffer-substring begin end))))
363                        (set-syntax-table mail-abbrev-syntax-table)          (delete-region begin end)
364                        (backward-word 1)          (insert expansion)))))
                       (point))  
                   (set-syntax-table syntax-table)))  
            (alias (buffer-substring beg end))  
            (expansion (mh-alias-expand alias)))  
       (delete-region beg end)  
       (insert expansion))))  
365    
366  ;;; Adding addresses to alias file.  ;;; Adding addresses to alias file.
367    
368  (defun mh-alias-suggest-alias (string)  (defun mh-alias-suggest-alias (string &optional no-comma-swap)
369    "Suggest an alias for STRING."    "Suggest an alias for STRING.
370    Don't reverse the order of strings separated by a comma if NO-COMMA-SWAP is
371    non-nil."
372    (cond    (cond
373     ((string-match "^<\\(.*\\)>$" string)     ((string-match "^<\\(.*\\)>$" string)
374      ;; <somename@foo.bar>  -> recurse, stripping brackets.      ;; <somename@foo.bar>  -> recurse, stripping brackets.
375      (mh-alias-suggest-alias (match-string 1 string)))      (mh-alias-suggest-alias (match-string 1 string) no-comma-swap))
376     ((string-match "^\\sw+$" string)     ((string-match "^\\sw+$" string)
377      ;; One word -> downcase it.      ;; One word -> downcase it.
378      (downcase string))      (downcase string))
# Line 372  Blind aliases or users from /etc/passwd Line 386  Blind aliases or users from /etc/passwd
386      (downcase (match-string 1 string)))      (downcase (match-string 1 string)))
387     ((string-match "^\"\\(.*\\)\".*" string)     ((string-match "^\"\\(.*\\)\".*" string)
388      ;; "Some name" <somename@foo.bar>  -> recurse -> "Some name"      ;; "Some name" <somename@foo.bar>  -> recurse -> "Some name"
389      (mh-alias-suggest-alias (match-string 1 string)))      (mh-alias-suggest-alias (match-string 1 string) no-comma-swap))
390     ((string-match "^\\(.*\\) +<.*>$" string)     ((string-match "^\\(.*\\) +<.*>$" string)
391      ;; Some name <somename@foo.bar>  -> recurse -> Some name      ;; Some name <somename@foo.bar>  -> recurse -> Some name
392      (mh-alias-suggest-alias (match-string 1 string)))      (mh-alias-suggest-alias (match-string 1 string) no-comma-swap))
393     ((string-match (concat mh-address-mail-regexp " +(\\(.*\\))$") string)     ((string-match (concat mh-address-mail-regexp " +(\\(.*\\))$") string)
394      ;; somename@foo.bar (Some name)  -> recurse -> Some name      ;; somename@foo.bar (Some name)  -> recurse -> Some name
395      (mh-alias-suggest-alias (match-string 1 string)))      (mh-alias-suggest-alias (match-string 1 string) no-comma-swap))
396     ((string-match "^\\(Dr\\|Prof\\)\\.? +\\(.*\\)" string)     ((string-match "^\\(Dr\\|Prof\\)\\.? +\\(.*\\)" string)
397      ;; Strip out title      ;; Strip out title
398      (mh-alias-suggest-alias (match-string 2 string)))      (mh-alias-suggest-alias (match-string 2 string) no-comma-swap))
399     ((string-match "^\\(.*\\), +\\(Jr\\.?\\|II+\\)$" string)     ((string-match "^\\(.*\\), +\\(Jr\\.?\\|II+\\)$" string)
400      ;; Strip out tails with comma      ;; Strip out tails with comma
401      (mh-alias-suggest-alias (match-string 1 string)))      (mh-alias-suggest-alias (match-string 1 string) no-comma-swap))
402     ((string-match "^\\(.*\\) +\\(Jr\\.?\\|II+\\)$" string)     ((string-match "^\\(.*\\) +\\(Jr\\.?\\|II+\\)$" string)
403      ;; Strip out tails      ;; Strip out tails
404      (mh-alias-suggest-alias (match-string 1 string)))      (mh-alias-suggest-alias (match-string 1 string) no-comma-swap))
405     ((string-match "^\\(\\sw+\\) +[A-Z]\\.? +\\(.*\\)$" string)     ((string-match "^\\(\\sw+\\) +[A-Z]\\.? +\\(.*\\)$" string)
406      ;; Strip out initials      ;; Strip out initials
407      (mh-alias-suggest-alias      (mh-alias-suggest-alias
408       (format "%s %s" (match-string 1 string) (match-string 2 string))))       (format "%s %s" (match-string 1 string) (match-string 2 string))
409     ((string-match "^\\([^,]+\\), +\\(.*\\)$" string)       no-comma-swap))
410      ;; Reverse order of comma-separated fields     ((and (not no-comma-swap)
411             (string-match "^\\([^,]+\\), +\\(.*\\)$" string))
412        ;; Reverse order of comma-separated fields to handle:
413        ;;  From: "Galbraith, Peter" <psg@debian.org>
414        ;; but don't this for a name string extracted from the passwd file
415        ;; with mh-alias-passwd-gecos-comma-separator-flag set to nil.
416      (mh-alias-suggest-alias      (mh-alias-suggest-alias
417       (format "%s %s" (match-string 2 string) (match-string 1 string))))       (format "%s %s" (match-string 2 string) (match-string 1 string))
418         no-comma-swap))
419     (t     (t
420      ;; Output string, with spaces replaced by dots.      ;; Output string, with spaces replaced by dots.
421      (mh-alias-canonicalize-suggestion string))))      (mh-alias-canonicalize-suggestion string))))
422    
423  (defun mh-alias-canonicalize-suggestion (string)  (defun mh-alias-canonicalize-suggestion (string)
424    "Process STRING to replace spacess by periods.    "Process STRING to replace spaces by periods.
425  First all spaces are replaced by periods. Then every run of consecutive periods  First all spaces and commas are replaced by periods. Then every run of
426  are replaced with a single period. Finally the string is converted to lower  consecutive periods are replaced with a single period. Finally the string
427  case."  is converted to lower case."
428    (with-temp-buffer    (with-temp-buffer
429      (insert string)      (insert string)
430      ;; Replace spaces with periods      ;; Replace spaces with periods
431      (goto-char (point-min))      (goto-char (point-min))
432      (replace-regexp " +" ".")      (while (re-search-forward " +" nil t)
433          (replace-match "." nil nil))
434        ;; Replace commas with periods
435        (goto-char (point-min))
436        (while (re-search-forward ",+" nil t)
437          (replace-match "." nil nil))
438      ;; Replace consecutive periods with a single period      ;; Replace consecutive periods with a single period
439      (goto-char (point-min))      (goto-char (point-min))
440      (replace-regexp "\\.\\.+" ".")      (while (re-search-forward "\\.\\.+" nil t)
441          (replace-match "." nil nil))
442      ;; Convert to lower case      ;; Convert to lower case
443      (downcase-region (point-min) (point-max))      (downcase-region (point-min) (point-max))
444      ;; Whew! all done...      ;; Whew! all done...
# Line 617  already has an alias." Line 643  already has an alias."
643          (mh-alias-add-alias nil address)          (mh-alias-add-alias nil address)
644        (message "No email address found under point."))))        (message "No email address found under point."))))
645    
646    ;;;###mh-autoload
647    (defun mh-alias-apropos (regexp)
648      "Show all aliases that match REGEXP either in name or content."
649      (interactive "sAlias regexp: ")
650      (if mh-alias-local-users
651          (mh-alias-reload-maybe))
652      (let ((matches "")(group-matches "")(passwd-matches))
653        (save-excursion
654          (message "Reading MH aliases...")
655          (mh-exec-cmd-quiet t "ali" "-nolist" "-nouser")
656          (message "Reading MH aliases...done.  Parsing...")
657          (while (re-search-forward regexp nil t)
658            (beginning-of-line)
659            (cond
660             ((looking-at "^[ \t]")         ;Continuation line
661              (setq group-matches
662                    (concat group-matches
663                            (buffer-substring
664                             (save-excursion
665                               (or (re-search-backward "^[^ \t]" nil t)
666                                   (point)))
667                             (progn
668                               (if (re-search-forward  "^[^ \t]" nil t)
669                                   (forward-char -1))
670                               (point))))))
671             (t
672              (setq matches
673                    (concat matches
674                            (buffer-substring (point)(progn (end-of-line)(point)))
675                            "\n")))))
676          (message "Reading MH aliases...done.  Parsing...done.")
677          (when mh-alias-local-users
678            (message
679             "Reading MH aliases...done.  Parsing...done.  Passwd aliases...")
680            (setq passwd-matches
681                  (mapconcat
682                   '(lambda (elem)
683                      (if (or (string-match regexp (car elem))
684                              (string-match regexp (cadr elem)))
685                          (format "%s: %s\n" (car elem) (cadr elem))))
686                   mh-alias-passwd-alist ""))
687            (message
688             "Reading MH aliases...done.  Parsing...done.  Passwd aliases...done.")))
689        (if (and (string-equal "" matches)
690                 (string-equal "" group-matches)
691                 (string-equal "" passwd-matches))
692            (message "No matches")
693          (with-output-to-temp-buffer "*Help*"
694            (if (not (string-equal "" matches))
695                (princ matches))
696            (when (not (string-equal group-matches ""))
697              (princ "\nGroup Aliases:\n\n")
698              (princ group-matches))
699            (when (not (string-equal passwd-matches ""))
700              (princ "\nLocal User Aliases:\n\n")
701              (princ passwd-matches))))))
702    
703  (provide 'mh-alias)  (provide 'mh-alias)
704    
705  ;;; Local Variables:  ;;; Local Variables:

Legend:
Removed from v.1.3.4.2  
changed lines
  Added in v.1.3.4.3

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26