home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 31 / CDASC_31_1996_juillet_aout.iso / vrac_os2 / e31el3.zip / EMACS / 19.31 / LISP / MAILALIA.EL < prev    next >
Lisp/Scheme  |  1996-03-22  |  16KB  |  435 lines
  1. ;;; mailalias.el --- expand and complete mailing address aliases
  2.  
  3. ;; Copyright (C) 1985, 1987, 1995, 1996 Free Software Foundation, Inc.
  4.  
  5. ;; Maintainer: FSF
  6. ;; Keywords: mail
  7.  
  8. ;; This file is part of GNU Emacs.
  9.  
  10. ;; GNU Emacs is free software; you can redistribute it and/or modify
  11. ;; it under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; GNU Emacs is distributed in the hope that it will be useful,
  16. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18. ;; GNU General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23. ;; Boston, MA 02111-1307, USA.
  24.  
  25. ;;; Commentary:
  26.  
  27. ;; Basic functions for defining and expanding mail aliases.
  28. ;; These seal off the interface to the alias-definition parts of a
  29. ;; .mailrc file formatted for BSD's Mail or USL's mailx.
  30.  
  31. ;;; Code:
  32.  
  33. (require 'sendmail)
  34.  
  35. (defvar mail-names t
  36.   "Alist of local users, aliases and directory entries as available.
  37. When t this still needs to be initialized.
  38. This is the basis for `mail-complete'.")
  39.  
  40. (defvar mail-local-names t
  41.   "Alist of local users.
  42. When t this still needs to be initialized.")
  43.  
  44. (defvar mail-directory-names t
  45.   "Alist of mail address directory entries.
  46. When t this still needs to be initialized.")
  47.  
  48. (defvar mail-address-field-regexp
  49.   "^\\(Resent-\\)?\\(To\\|From\\|CC\\|BCC\\|Reply-to\\):")
  50.  
  51. (defvar mail-complete-alist
  52.   `((,mail-address-field-regexp mail-get-names pattern)
  53.     ("Newsgroups:" . (if (boundp 'gnus-active-hashtb)
  54.              gnus-active-hashtb
  55.                (if (boundp news-group-article-assoc)
  56.                news-group-article-assoc)))
  57.     ("Followup-To:" . (mail-sentto-newsgroups))
  58.     ;;("Distribution:" ???)
  59.     )
  60.   "Alist of header field and expression to return alist for completion.
  61. Expression may reference variable `pattern' which is the string being completed.
  62. If not on matching header, `mail-complete-function' gets called instead.")
  63.  
  64. (defvar mail-complete-function 'ispell-complete-word
  65.   "Function to call when completing outside `mail-complete-alist'-header.")
  66.  
  67.  
  68. (defvar mail-directory-function nil
  69.   "Function to get completions from directory service or `nil' for none.
  70. See `mail-directory-requery'.")
  71.  
  72.  
  73. ;; This is for when the directory is huge, or changes frequently.
  74. (defvar mail-directory-requery nil
  75.   "When non-`nil' call `mail-directory-function' for each completion.
  76. In that case, one argument gets passed to the function, the partial string
  77. entered so far.")
  78.  
  79.  
  80. (defvar mail-directory-process nil
  81.   "Unix command when `mail-directory-function' is `mail-directory-process'.
  82. This is a list of the form (COMMAND ARG ...), where each of the list elements
  83. is evaluated.  When `mail-directory-requery' is non-`nil', during
  84. evaluation the variable `pattern' contains the partial input being completed.
  85. This might look like
  86.  
  87.   '(remote-shell-program \"HOST\" \"-nl\" \"USER\" \"COMMAND\")
  88.  
  89. or
  90.  
  91.   '(remote-shell-program \"HOST\" \"-n\" \"COMMAND '^\" pattern \"'\")")
  92.  
  93. (defvar mail-directory-stream ()
  94.   "List of (HOST SERVICE) for stream connection to mail directory.")
  95.  
  96. (defvar mail-directory-parser nil
  97.   "How to interpret the output of `mail-directory-function'.
  98. Three types of values are possible:
  99.  
  100.   - nil means to gather each line as one name
  101.   - regexp means first \\(grouping\\) in successive matches is name
  102.   - function called at beginning of buffer that returns an alist of names")
  103.  
  104.  
  105. ;; Called from sendmail-send-it, or similar functions,
  106. ;; only if some mail aliases are defined.
  107. (defun expand-mail-aliases (beg end &optional exclude)
  108.   "Expand all mail aliases in suitable header fields found between BEG and END.
  109. Suitable header fields are `To', `From', `CC' and `BCC', `Reply-to', and
  110. their `Resent-' variants.
  111.  
  112. Optional second arg EXCLUDE may be a regular expression defining text to be
  113. removed from alias expansions."
  114.   (sendmail-sync-aliases)
  115.   (if (eq mail-aliases t)
  116.       (progn (setq mail-aliases nil) (build-mail-aliases)))
  117.   (goto-char beg)
  118.   (setq end (set-marker (make-marker) end))
  119.   (let ((case-fold-search nil))
  120.     (while (let ((case-fold-search t))
  121.          (re-search-forward mail-address-field-regexp end t))
  122.       (skip-chars-forward " \t")
  123.       (let ((beg1 (point))
  124.         end1 pos epos seplen
  125.         ;; DISABLED-ALIASES records aliases temporarily disabled
  126.         ;; while we scan text that resulted from expanding those aliases.
  127.         ;; Each element is (ALIAS . TILL-WHEN), where TILL-WHEN
  128.         ;; is where to reenable the alias (expressed as number of chars
  129.         ;; counting from END1).
  130.         (disabled-aliases nil))
  131.     (re-search-forward "^[^ \t]" end 'move)
  132.     (beginning-of-line)
  133.     (skip-chars-backward " \t\n")
  134.     (setq end1 (point-marker))
  135.     (goto-char beg1)
  136.     (while (< (point) end1)
  137.       (setq pos (point))
  138.       ;; Reenable any aliases which were disabled for ranges
  139.       ;; that we have passed out of.
  140.       (while (and disabled-aliases (> pos (- end1 (cdr (car disabled-aliases)))))
  141.         (setq disabled-aliases (cdr disabled-aliases)))
  142.       ;; EPOS gets position of end of next name;
  143.       ;; SEPLEN gets length of whitespace&separator that follows it.
  144.       (if (re-search-forward "[ \t]*[\n,][ \t]*" end1 t)
  145.           (setq epos (match-beginning 0)
  146.             seplen (- (point) epos))
  147.         (setq epos (marker-position end1) seplen 0))
  148.       (let (translation
  149.         (string (buffer-substring-no-properties pos epos)))
  150.         (if (and (not (assoc string disabled-aliases))
  151.              (setq translation
  152.                (cdr (assoc string mail-aliases))))
  153.         (progn
  154.           ;; This name is an alias.  Disable it.
  155.           (setq disabled-aliases (cons (cons string (- end1 epos))
  156.                            disabled-aliases))
  157.           ;; Replace the alias with its expansion
  158.           ;; then rescan the expansion for more aliases.
  159.           (goto-char pos)
  160.           (insert translation)
  161.           (if exclude
  162.                (let ((regexp
  163.                  (concat "\\b\\(" exclude "\\)\\b"))
  164.                 (end (point-marker)))
  165.             (goto-char pos)
  166.             (while (re-search-forward regexp end t)
  167.               (replace-match ""))
  168.             (goto-char end)))
  169.           (delete-region (point) (+ (point) (- epos pos)))
  170.           (goto-char pos))
  171.           ;; Name is not an alias.  Skip to start of next name.
  172.           (goto-char epos)
  173.           (forward-char seplen))))
  174.     (set-marker end1 nil)))
  175.     (set-marker end nil)))
  176.  
  177. ;; Called by mail-setup, or similar functions, only if the file specified
  178. ;; by mail-personal-alias-file (usually `~/.mailrc') exists.
  179. (defun build-mail-aliases (&optional file)
  180.   "Read mail aliases from personal aliases file and set `mail-aliases'.
  181. By default, this is the file specified by `mail-personal-alias-file'."
  182.   (setq file (expand-file-name (or file mail-personal-alias-file)))
  183.   (let ((buffer nil)
  184.     (obuf (current-buffer)))
  185.     (unwind-protect
  186.     (progn
  187.       (setq buffer (generate-new-buffer " mailrc"))
  188.       (set-buffer buffer)
  189.       (while file
  190.         (cond ((get-file-buffer file)
  191.            (insert (save-excursion
  192.                  (set-buffer (get-file-buffer file))
  193.                  (buffer-substring-no-properties
  194.                   (point-min) (point-max)))))
  195.           ((file-exists-p file) (insert-file-contents file))
  196.           ((file-exists-p (setq file (concat "~/" file)))
  197.            (insert-file-contents file))
  198.           (t (setq file nil)))
  199.         ;; Don't lose if no final newline.
  200.         (goto-char (point-max))
  201.         (or (eq (preceding-char) ?\n) (newline))
  202.         (goto-char (point-min))
  203.         ;; handle "\\\n" continuation lines
  204.         (while (not (eobp))
  205.           (end-of-line)
  206.           (if (= (preceding-char) ?\\)
  207.           (progn (delete-char -1) (delete-char 1) (insert ?\ ))
  208.             (forward-char 1)))
  209.         (goto-char (point-min))
  210.         ;; handle `source' directives -- Eddy/1994/May/25
  211.         (cond ((re-search-forward "^source[ \t]+" nil t)
  212.            (re-search-forward "\\S-+")
  213.            (setq file (buffer-substring-no-properties
  214.                    (match-beginning 0) (match-end 0)))
  215.            (beginning-of-line)
  216.            (insert "# ") ; to ensure we don't re-process this file
  217.            (beginning-of-line))
  218.           (t (setq file nil))))
  219.       (goto-char (point-min))
  220.       (while (re-search-forward
  221.           "^\\(a\\|alias\\|g\\|group\\)[ \t]+\\([^ \t]+\\)" nil t)
  222.         (let* ((name (match-string 2))
  223.            (start (progn (skip-chars-forward " \t") (point))))
  224.           (end-of-line)
  225.           (define-mail-alias
  226.         name
  227.         (buffer-substring-no-properties start (point))
  228.         t)))
  229.       mail-aliases)
  230.       (if buffer (kill-buffer buffer))
  231.       (set-buffer obuf))))
  232.  
  233. ;; Always autoloadable in case the user wants to define aliases
  234. ;; interactively or in .emacs.
  235. ;;;###autoload
  236. (defun define-mail-alias (name definition &optional from-mailrc-file)
  237.   "Define NAME as a mail alias that translates to DEFINITION.
  238. This means that sending a message to NAME will actually send to DEFINITION.
  239.  
  240. Normally, the addresses in DEFINITION must be separated by commas.
  241. If FROM-MAILRC-FILE is non-nil, then addresses in DEFINITION 
  242. can be separated by spaces; an address can contain spaces
  243. if it is quoted with double-quotes."
  244.  
  245.   (interactive "sDefine mail alias: \nsDefine %s as mail alias for: ")
  246.   ;; Read the defaults first, if we have not done so.
  247.   (sendmail-sync-aliases)
  248.   (if (eq mail-aliases t)
  249.       (progn
  250.     (setq mail-aliases nil)
  251.     (if (file-exists-p mail-personal-alias-file)
  252.         (build-mail-aliases))))
  253.   ;; strip garbage from front and end
  254.   (if (string-match "\\`[ \t\n,]+" definition)
  255.       (setq definition (substring definition (match-end 0))))
  256.   (if (string-match "[ \t\n,]+\\'" definition)
  257.       (setq definition (substring definition 0 (match-beginning 0))))
  258.   (let ((result '())
  259.     ;; If DEFINITION is null string, avoid looping even once.
  260.     (start (and (not (equal definition "")) 0))
  261.     (L (length definition))
  262.     end tem)
  263.     (while start
  264.       ;; If we're reading from the mailrc file, then addresses are delimited
  265.       ;; by spaces, and addresses with embedded spaces must be surrounded by
  266.       ;; double-quotes.  Otherwise, addresses are separated by commas.
  267.       (if from-mailrc-file
  268.       (if (eq ?\" (aref definition start))
  269.           (setq start (1+ start)
  270.             end (string-match "\"[ \t,]*" definition start))
  271.         (setq end (string-match "[ \t,]+" definition start)))
  272.     (setq end (string-match "[ \t\n,]*,[ \t\n,]*" definition start)))
  273.       (setq result (cons (substring definition start end) result))
  274.       (setq start (and end
  275.                (/= (match-end 0) L)
  276.                (match-end 0))))
  277.     (setq definition (mapconcat (function identity)
  278.                 (nreverse result)
  279.                 ", "))
  280.     (setq tem (assoc name mail-aliases))
  281.     (if tem
  282.     (rplacd tem definition)
  283.       (setq mail-aliases (cons (cons name definition) mail-aliases)
  284.         mail-names t))))
  285.  
  286. ;;;###autoload
  287. (defun mail-complete (arg)
  288.   "Perform completion on header field or word preceding point.
  289. Completable headers are according to `mail-complete-alist'.  If none matches
  290. current header, calls `mail-complete-function' and passes prefix arg if any."
  291.   (interactive "P")
  292.   (let ((list mail-complete-alist))
  293.     (if (and (save-excursion (search-forward
  294.                   (concat "\n" mail-header-separator "\n")
  295.                   nil t))
  296.          (save-excursion
  297.            (if (re-search-backward "^[^\t]" nil t)
  298.            (while list
  299.              (if (looking-at (car (car list)))
  300.              (setq arg (cdr (car list))
  301.                    list ())
  302.                (setq list (cdr list)))))
  303.            arg))
  304.     (let* ((end (point))
  305.            (beg (save-excursion
  306.               (skip-chars-backward "^ \t<,:")
  307.               (point)))
  308.            (pattern (buffer-substring beg end))
  309.            completion)
  310.       (setq list (eval arg)
  311.         completion (try-completion pattern list))
  312.       (cond ((eq completion t))
  313.         ((null completion)
  314.          (message "Can't find completion for \"%s\"" pattern)
  315.          (ding))
  316.         ((not (string= pattern completion))
  317.          (delete-region beg end)
  318.          (insert completion))
  319.         (t
  320.          (message "Making completion list...")
  321.          (with-output-to-temp-buffer "*Completions*"
  322.            (display-completion-list
  323.             (all-completions pattern list)))
  324.          (message "Making completion list...%s" "done"))))
  325.       (funcall mail-complete-function arg))))
  326.  
  327. (defun mail-get-names (pattern)
  328.   "Fetch local users and global mail adresses for completion.
  329. Consults `/etc/passwd' and a directory service if one is set up via
  330. `mail-directory-function'."
  331.   (if (eq mail-local-names t)
  332.       (save-excursion
  333.     (set-buffer (generate-new-buffer " passwd"))
  334.     (insert-file-contents "/etc/passwd" nil nil nil t)
  335.     (setq mail-local-names)
  336.     (while (not (eobp))
  337.       ;;Recognize lines like
  338.       ;;  nobody:*:65534:65534::/:
  339.       ;;  +demo::::::/bin/csh
  340.       ;;  +ethanb
  341.       ;;while skipping
  342.       ;;  +@SOFTWARE
  343.       (if (looking-at "\\+?\\([^:@\n+]+\\)")
  344.           (add-to-list 'mail-local-names (list (match-string 1))))
  345.       (beginning-of-line 2))
  346.     (kill-buffer (current-buffer))))
  347.   (if (or (eq mail-names t)
  348.         (eq mail-directory-names t))
  349.       (let (directory)
  350.     (and mail-directory-function
  351.          (eq mail-directory-names t)
  352.          (setq directory
  353.            (mail-directory (if mail-directory-requery pattern))))
  354.     (if (or directory
  355.         (eq mail-names t))
  356.         (setq mail-names
  357.           (sort (append (if (consp mail-aliases) mail-aliases)
  358.                 (if (consp mail-local-names)
  359.                     mail-local-names)
  360.                 directory)
  361.             (lambda (a b)
  362.               ;; should cache downcased strings
  363.               (string< (downcase (car a))
  364.                    (downcase (car b)))))))
  365.     (or mail-directory-requery
  366.         (setq mail-directory-names directory))))
  367.   mail-names)
  368.  
  369.  
  370. (defun mail-directory (pattern)
  371.   "Call directory to get names matching PATTERN or all if `nil'.
  372. Calls `mail-directory-function' and applies `mail-directory-parser' to output."
  373.   (save-excursion
  374.     (message "Querying directory...")
  375.     (set-buffer (generate-new-buffer " *mail-directory*"))
  376.     (funcall mail-directory-function pattern)
  377.     (goto-char 1)
  378.     (let (directory)
  379.       (if (stringp mail-directory-parser)
  380.       (while (re-search-forward mail-directory-parser nil t)
  381.         (setq directory
  382.           `((,(match-string 1))
  383.             ,@directory)))
  384.     (if mail-directory-parser
  385.         (setq directory (funcall mail-directory-parser))
  386.       (while (not (eobp))
  387.         (setq directory
  388.           `((,(buffer-substring (point)
  389.                     (progn
  390.                       (forward-line)
  391.                       (if (bolp)
  392.                         (1- (point))
  393.                         (point)))))
  394.             ,@directory)))))
  395.       (kill-buffer (current-buffer))
  396.       (message "Querying directory...done")
  397.       directory)))
  398.  
  399.  
  400. (defun mail-directory-process (pattern)
  401.   "Call a Unix process to output names in directory.
  402. See `mail-directory-process'."
  403.   (apply 'call-process (eval (car mail-directory-process)) nil t nil
  404.      (mapcar 'eval (cdr mail-directory-process))))
  405.  
  406. ;; This should handle a dialog.  Currently expects port to spit out names.
  407. (defun mail-directory-stream (pattern)
  408.   "Open a stream to retrieve names in directory.
  409. See `mail-directory-stream'."
  410.   (let (mailalias-done)
  411.     (set-process-sentinel
  412.      (apply 'open-network-stream "mailalias" (current-buffer)
  413.         mail-directory-stream)
  414.      (lambda (x x)
  415.        (setq mailalias-done t)))
  416.     (while (not mailalias-done)
  417.       (sit-for .1))))
  418.  
  419. (defun mail-sentto-newsgroups ()
  420.   "Return all entries from Newsgroups: header as completion alist."
  421.   (save-excursion
  422.     (if (mail-position-on-field "newsgroups" t)
  423.     (let ((point (point))
  424.           list)
  425.       (while (< (skip-chars-backward "^:, \t\n") 0)
  426.         (setq list `((,(buffer-substring (point) point))
  427.              ,@list))
  428.         (skip-chars-backward ", \t\n")
  429.         (setq point (point)))
  430.       list))))
  431.  
  432. (provide 'mailalias)
  433.  
  434. ;;; mailalias.el ends here
  435.