home *** CD-ROM | disk | FTP | other *** search
/ OpenStep 4.2J (Developer) / os42jdev.iso / NextDeveloper / Source / GNU / emacs / lisp / sendmail.el < prev    next >
Lisp/Scheme  |  1992-03-25  |  16KB  |  470 lines
  1. ;; Mail sending commands for Emacs.
  2. ;; Copyright (C) 1985, 1986 Free Software Foundation, Inc.
  3.  
  4. ;; This file is part of GNU Emacs.
  5.  
  6. ;; GNU Emacs is free software; you can redistribute it and/or modify
  7. ;; it under the terms of the GNU General Public License as published by
  8. ;; the Free Software Foundation; either version 1, or (at your option)
  9. ;; any later version.
  10.  
  11. ;; GNU Emacs is distributed in the hope that it will be useful,
  12. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;; GNU General Public License for more details.
  15.  
  16. ;; You should have received a copy of the GNU General Public License
  17. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  18. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20.  
  21. (provide 'sendmail)
  22.  
  23. ;(defconst mail-self-blind nil
  24. ;  "Non-nil means insert BCC to self in messages to be sent.
  25. ;This is done when the message is initialized,
  26. ;so you can remove or alter the BCC field to override the default.")
  27.  
  28. ;(defconst mail-interactive nil
  29. ;  "Non-nil means when sending a message wait for and display errors.
  30. ;nil means let mailer mail back a message to report errors.")
  31.  
  32. ;(defconst mail-yank-ignored-headers
  33. ;   "^via:\\|^mail-from:\\|^origin:\\|^status:\\|^remailed\\|^received:\\|^message-id:\\|^summary-line:\\|^to:\\|^subject:\\|^in-reply-to:\\|^return-path:"
  34. ;   "Delete these headers from old message when it's inserted in a reply.")
  35. ;(defvar send-mail-function 'sendmail-send-it
  36. ;  "Function to call to send the current buffer as mail.
  37. ;The headers are be delimited by a line which is mail-header-separator"")
  38.  
  39. ; really defined in loaddefs for emacs 17.17+
  40. ;(defvar mail-header-separator "--text follows this line--"
  41. ;  "*Line used to separate headers from text in messages being composed.")
  42. ; really defined in loaddefs for emacs 17.17+
  43. ;(defvar mail-archive-file-name nil
  44. ;  "*Name of file to write all outgoing messages in, or nil for none.")
  45. ; really defined in loaddefs for emacs 17.17+
  46. (defvar mail-aliases t
  47.   "Alias of mail address aliases,
  48. or t meaning should be initialized from .mailrc.")
  49.  
  50. (defvar mail-default-reply-to nil
  51.   "*Address to insert as default Reply-to field of outgoing messages.")
  52.  
  53. (defvar mail-abbrevs-loaded nil)
  54. (defvar mail-mode-map nil)
  55.  
  56. (autoload 'build-mail-aliases "mailalias"
  57.   "Read mail aliases from ~/.mailrc and set mail-aliases."
  58.   nil)
  59.  
  60. (autoload 'expand-mail-aliases "mailalias"
  61.   "Expand all mail aliases in suitable header fields found between BEG and END.
  62. Suitable header fields are To, CC and BCC."
  63.   nil)
  64.  
  65. (defun mail-setup (to subject in-reply-to cc replybuffer)
  66.   (if (eq mail-aliases t)
  67.       (progn
  68.     (setq mail-aliases nil)
  69.     (if (file-exists-p "~/.mailrc")
  70.         (build-mail-aliases))))
  71.   (setq mail-reply-buffer replybuffer)
  72.   (goto-char (point-min))
  73.   (insert "To: ")
  74.   (save-excursion
  75.     (if to
  76.     (progn
  77.       (insert to "\n")
  78.       ;;; Here removed code to extract names from within <...>
  79.       ;;; on the assumption that mail-strip-quoted-names
  80.       ;;; has been called and has done so.
  81.       (let ((fill-prefix "\t"))
  82.         (fill-region (point-min) (point-max))))
  83.       (newline))
  84.     (if cc
  85.     (let ((opos (point))
  86.           (fill-prefix "\t"))
  87.       (insert "CC: " cc "\n")
  88.       (fill-region-as-paragraph opos (point-max))))
  89.     (if in-reply-to
  90.     (insert "In-reply-to: " in-reply-to "\n"))
  91.     (insert "Subject: " (or subject "") "\n")
  92.     (if mail-default-reply-to
  93.     (insert "Reply-to: " mail-default-reply-to "\n"))
  94.     (if mail-self-blind
  95.     (insert "BCC: " (user-login-name) "\n"))
  96.     (if mail-archive-file-name
  97.     (insert "FCC: " mail-archive-file-name "\n"))
  98.     (insert mail-header-separator "\n"))
  99.   (if to (goto-char (point-max)))
  100.   (or to subject in-reply-to
  101.       (set-buffer-modified-p nil))
  102.   (run-hooks 'mail-setup-hook))
  103.  
  104. (defun mail-mode ()
  105.   "Major mode for editing mail to be sent.
  106. Separate names of recipients (in To: and Cc: fields) with commas.
  107. Like Text Mode but with these additional commands:
  108. C-c C-s  mail-send (send the message)    C-c C-c  mail-send-and-exit
  109. C-c C-f  move to a header field (and create it if there isn't):
  110.      C-c C-f C-t  move to To:    C-c C-f C-s  move to Subj:
  111.      C-c C-f C-b  move to BCC:    C-c C-f C-c  move to CC:
  112. C-c C-w  mail-signature (insert ~/.signature at end).
  113. C-c C-y  mail-yank-original (insert current message, in Rmail).
  114. C-c C-q  mail-fill-yanked-message (fill what was yanked)."
  115.   (interactive)
  116.   (kill-all-local-variables)
  117.   (make-local-variable 'mail-reply-buffer)
  118.   (setq mail-reply-buffer nil)
  119.   (set-syntax-table text-mode-syntax-table)
  120.   (use-local-map mail-mode-map)
  121.   (setq local-abbrev-table text-mode-abbrev-table)
  122.   (setq major-mode 'mail-mode)
  123.   (setq mode-name "Mail")
  124.   (setq buffer-offer-save t)
  125.   (make-local-variable 'paragraph-separate)
  126.   (make-local-variable 'paragraph-start)
  127.   (setq paragraph-start (concat "^" mail-header-separator
  128.                 "$\\|^[ \t]*[-_][-_][-_]+$\\|"
  129.                 paragraph-start))
  130.   (setq paragraph-separate (concat "^" mail-header-separator
  131.                    "$\\|^[ \t]*[-_][-_][-_]+$\\|"
  132.                    paragraph-separate))
  133.   (run-hooks 'text-mode-hook 'mail-mode-hook))
  134.  
  135. (if mail-mode-map
  136.     nil
  137.   (setq mail-mode-map (make-sparse-keymap))
  138.   (define-key mail-mode-map "\C-c?" 'describe-mode)
  139.   (define-key mail-mode-map "\C-c\C-f\C-t" 'mail-to)
  140.   (define-key mail-mode-map "\C-c\C-f\C-b" 'mail-bcc)
  141.   (define-key mail-mode-map "\C-c\C-f\C-c" 'mail-cc)
  142.   (define-key mail-mode-map "\C-c\C-f\C-s" 'mail-subject)
  143.   (define-key mail-mode-map "\C-c\C-w" 'mail-signature)        ; who
  144.   (define-key mail-mode-map "\C-c\C-y" 'mail-yank-original)
  145.   (define-key mail-mode-map "\C-c\C-q" 'mail-fill-yanked-message)
  146.   (define-key mail-mode-map "\C-c\C-c" 'mail-send-and-exit)
  147.   (define-key mail-mode-map "\C-c\C-s" 'mail-send))
  148.  
  149. (defun mail-send-and-exit (arg)
  150.   "Send message like mail-send, then, if no errors, exit from mail buffer.
  151. Prefix arg means don't delete this window."
  152.   (interactive "P")
  153.   (mail-send)
  154.   (bury-buffer (current-buffer))
  155.   (if (and (not arg)
  156.        (not (one-window-p))
  157.        (save-excursion
  158.          (set-buffer (window-buffer (next-window (selected-window) 'not)))
  159.          (eq major-mode 'rmail-mode)))
  160.       (delete-window)
  161.     (switch-to-buffer (other-buffer (current-buffer)))))
  162.  
  163. (defun mail-send ()
  164.   "Send the message in the current buffer.
  165. If  mail-interactive  is non-nil, wait for success indication
  166. or error messages, and inform user.
  167. Otherwise any failure is reported in a message back to
  168. the user from the mailer."
  169.   (interactive)
  170.   (message "Sending...")
  171.   (funcall send-mail-function)
  172.   (set-buffer-modified-p nil)
  173.   (delete-auto-save-file-if-necessary)
  174.   (message "Sending...done"))
  175.  
  176. (defun sendmail-send-it ()
  177.   (let ((errbuf (if mail-interactive
  178.             (generate-new-buffer " sendmail errors")
  179.           0))
  180.     (tembuf (generate-new-buffer " sendmail temp"))
  181.     (case-fold-search nil)
  182.     delimline
  183.     (mailbuf (current-buffer)))
  184.     (unwind-protect
  185.     (save-excursion
  186.       (set-buffer tembuf)
  187.       (setq buffer-undo-list t)
  188.       (erase-buffer)
  189.       (insert-buffer-substring mailbuf)
  190.       (goto-char (point-max))
  191.       ;; require one newline at the end.
  192.       (or (= (preceding-char) ?\n)
  193.           (insert ?\n))
  194.       ;; Change header-delimiter to be what sendmail expects.
  195.       (goto-char (point-min))
  196.       (re-search-forward
  197.         (concat "^" (regexp-quote mail-header-separator) "\n"))
  198.       (replace-match "\n")
  199.       (backward-char 1)
  200.       (setq delimline (point-marker))
  201.       (if mail-aliases
  202.           (expand-mail-aliases (point-min) delimline))
  203.       (goto-char (point-min))
  204.       ;; ignore any blank lines in the header
  205.       (while (and (re-search-forward "\n\n\n*" delimline t)
  206.               (< (point) delimline))
  207.         (replace-match "\n"))
  208.       (let ((case-fold-search t))
  209.         ;; Find and handle any FCC fields.
  210.         (goto-char (point-min))
  211.         (if (re-search-forward "^FCC:" delimline t)
  212.         (mail-do-fcc delimline))
  213.         ;; If there is a From and no Sender, put it a Sender.
  214.         (goto-char (point-min))
  215.         (and (re-search-forward "^From:"  delimline t)
  216.          (not (save-excursion
  217.             (goto-char (point-min))
  218.             (re-search-forward "^Sender:" delimline t)))
  219.          (progn
  220.            (forward-line 1)
  221.            (insert "Sender: " (user-login-name) "\n")))
  222.         ;; don't send out a blank subject line
  223.         (goto-char (point-min))
  224.         (if (re-search-forward "^Subject:[ \t]*\n" delimline t)
  225.         (replace-match ""))
  226.         (if mail-interactive
  227.         (save-excursion
  228.           (set-buffer errbuf)
  229.           (erase-buffer))))
  230.       (apply 'call-process-region
  231.          (append (list (point-min) (point-max)
  232.                    (if (boundp 'sendmail-program)
  233.                    sendmail-program
  234.                  "/usr/lib/sendmail")
  235.                    nil errbuf nil
  236.                    "-oi" "-t")
  237.              ;; Always specify who from,
  238.              ;; since some systems have broken sendmails.
  239.              (list "-f" (user-login-name))
  240. ;;;             ;; Don't say "from root" if running under su.
  241. ;;;             (and (equal (user-real-login-name) "root")
  242. ;;;                  (list "-f" (user-login-name)))
  243.              ;; These mean "report errors by mail"
  244.              ;; and "deliver in background".
  245.              (if (null mail-interactive) '("-oem" "-odb"))))
  246.       (if mail-interactive
  247.           (save-excursion
  248.         (set-buffer errbuf)
  249.         (goto-char (point-min))
  250.         (while (re-search-forward "\n\n* *" nil t)
  251.           (replace-match "; "))
  252.         (if (not (zerop (buffer-size)))
  253.             (error "Sending...failed to %s"
  254.                (buffer-substring (point-min) (point-max)))))))
  255.       (kill-buffer tembuf)
  256.       (if (bufferp errbuf)
  257.       (kill-buffer errbuf)))))
  258.  
  259. (defun mail-do-fcc (header-end)
  260.   (let (fcc-list
  261.     (rmailbuf (current-buffer))
  262.     timezone
  263.     (tembuf (generate-new-buffer " rmail output"))
  264.     (case-fold-search t))
  265.     (save-excursion
  266.       (goto-char (point-min))
  267.       (while (re-search-forward "^FCC:[ \t]*" header-end t)
  268.     (setq fcc-list (cons (buffer-substring (point)
  269.                            (progn
  270.                          (end-of-line)
  271.                          (skip-chars-backward " \t")
  272.                          (point)))
  273.                  fcc-list))
  274.     (delete-region (match-beginning 0)
  275.                (progn (forward-line 1) (point))))
  276.       (set-buffer tembuf)
  277.       (erase-buffer)
  278.       (call-process "date" nil t nil)
  279.       (goto-char (point-min))
  280.       (re-search-forward 
  281.         "[0-9] \\([A-Za-z][A-Za-z ]*[A-Za-z]\\)[0-9 ]*$")
  282.       (setq timezone (buffer-substring (match-beginning 1) (match-end 1)))
  283.       (erase-buffer)
  284.       (insert "\nFrom " (user-login-name) " "
  285.           (current-time-string) "\n")
  286.       ;; Insert the time zone before the year.
  287.       (forward-char -1)
  288.       (forward-word -1)
  289.       (insert timezone " ")
  290.       (goto-char (point-max))
  291.       (insert-buffer-substring rmailbuf)
  292.       ;; Make sure messages are separated.
  293.       (goto-char (point-max))
  294.       (insert ?\n)
  295.       (goto-char 2)
  296.       ;; ``Quote'' "^From " as ">From "
  297.       ;;  (note that this isn't really quoting, as there is no requirement
  298.       ;;   that "^[>]+From " be quoted in the same transparent way.)
  299.       (let ((case-fold-search nil))
  300.     (while (search-forward "\nFrom " nil t)
  301.       (forward-char -5)
  302.       (insert ?>)))
  303.       (while fcc-list
  304.     (let ((buffer (get-file-buffer (car fcc-list))))
  305.       (if buffer
  306.           ;; File is present in a buffer => append to that buffer.
  307.           (let ((curbuf (current-buffer))
  308.             (beg (point-min)) (end (point-max)))
  309.         (save-excursion
  310.           (set-buffer buffer)
  311.           (goto-char (point-max))
  312.           (insert-buffer-substring curbuf beg end)))
  313.         ;; Else append to the file directly.
  314.         (write-region (point-min) (point-max) (car fcc-list) t)))
  315.     (setq fcc-list (cdr fcc-list))))
  316.     (kill-buffer tembuf)))
  317.  
  318. (defun mail-to ()
  319.   "Move point to end of To-field."
  320.   (interactive)
  321.   (expand-abbrev)
  322.   (mail-position-on-field "To"))
  323.  
  324. (defun mail-subject ()
  325.   "Move point to end of Subject-field."
  326.   (interactive)
  327.   (expand-abbrev)
  328.   (mail-position-on-field "Subject"))
  329.  
  330. (defun mail-cc ()
  331.   "Move point to end of CC-field.  Create a CC field if none."
  332.   (interactive)
  333.   (expand-abbrev)
  334.   (or (mail-position-on-field "cc" t)
  335.       (progn (mail-position-on-field "to")
  336.          (insert "\nCC: "))))
  337.  
  338. (defun mail-bcc ()
  339.   "Move point to end of BCC-field.  Create a BCC field if none."
  340.   (interactive)
  341.   (expand-abbrev)
  342.   (or (mail-position-on-field "bcc" t)
  343.       (progn (mail-position-on-field "to")
  344.          (insert "\nBCC: "))))
  345.  
  346. (defun mail-position-on-field (field &optional soft)
  347.   (let (end
  348.     (case-fold-search t))
  349.     (goto-char (point-min))
  350.     (re-search-forward
  351.      (concat "^" (regexp-quote mail-header-separator) "\n"))
  352.     (setq end (match-beginning 0))
  353.     (goto-char (point-min))
  354.     (if (re-search-forward (concat "^" (regexp-quote field) ":") end t)
  355.     (progn
  356.       (re-search-forward "^[^ \t]" nil 'move)
  357.       (beginning-of-line)
  358.       (skip-chars-backward "\n")
  359.       t)
  360.       (or soft
  361.       (progn (goto-char end)
  362.          (insert field ": \n")
  363.          (skip-chars-backward "\n")))
  364.       nil)))
  365.  
  366. (defun mail-signature ()
  367.   "Sign letter with contents of ~/.signature file."
  368.   (interactive)
  369.   (save-excursion
  370.     (goto-char (point-max))
  371.     (insert-file-contents (expand-file-name "~/.signature"))))
  372.  
  373. (defun mail-fill-yanked-message (&optional justifyp)
  374.   "Fill the paragraphs of a message yanked into this one.
  375. Numeric argument means justify as well."
  376.   (interactive "P")
  377.   (save-excursion
  378.     (goto-char (point-min))
  379.     (search-forward (concat "\n" mail-header-separator "\n") nil t)
  380.     (fill-individual-paragraphs (point)
  381.                 (point-max)
  382.                 justifyp
  383.                 t)))
  384. (defun mail-yank-original (arg)
  385.   "Insert the message being replied to, if any (in rmail).
  386. Puts point before the text and mark after.
  387. Indents each nonblank line ARG spaces (default 3).
  388. Just \\[universal-argument] as argument means don't indent
  389. and don't delete any header fields."
  390.   (interactive "P")
  391.   (if mail-reply-buffer
  392.       (let ((start (point)))
  393.     (delete-windows-on mail-reply-buffer)
  394.     (insert-buffer mail-reply-buffer)
  395.     (if (consp arg)
  396.         nil
  397.       (mail-yank-clear-headers start (mark))
  398.       (indent-rigidly start (mark)
  399.               (if arg (prefix-numeric-value arg) 3)))
  400.     (exchange-point-and-mark)
  401.     (if (not (eolp)) (insert ?\n)))))
  402.  
  403. (defun mail-yank-clear-headers (start end)
  404.   (save-excursion
  405.     (goto-char start)
  406.     (if (search-forward "\n\n" end t)
  407.     (save-restriction
  408.       (narrow-to-region start (point))
  409.       (goto-char start)
  410.       (while (let ((case-fold-search t))
  411.            (re-search-forward mail-yank-ignored-headers nil t))
  412.         (beginning-of-line)
  413.         (delete-region (point)
  414.                (progn (re-search-forward "\n[^ \t]")
  415.                   (forward-char -1)
  416.                   (point))))))))
  417.  
  418. ;; Put these last, to reduce chance of lossage from quitting in middle of loading the file.
  419.  
  420. (defun mail (&optional noerase to subject in-reply-to cc replybuffer)
  421.   "Edit a message to be sent.  Argument means resume editing (don't erase).
  422. Returns with message buffer selected; value t if message freshly initialized.
  423. While editing message, type C-c C-c to send the message and exit.
  424.  
  425. Separate names of recipients with commas.
  426.  
  427. Various special commands starting with C-c are available in sendmail mode
  428. to move to message header fields:
  429. \\{mail-mode-map}
  430.  
  431. If mail-self-blind is non-nil, a BCC to yourself is inserted
  432. when the message is initialized.
  433.  
  434. If mail-default-reply-to is non-nil, it should be an address (a string);
  435. a Reply-to: field with that address is inserted.
  436.  
  437. If mail-archive-file-name is non-nil, an FCC field with that file name
  438. is inserted.
  439.  
  440. If mail-setup-hook is bound, its value is run by means of run-hooks
  441. after the message is initialized.  It can add more default fields.
  442. See the documentation of run-hooks.
  443.  
  444. When calling from a program, the second through fifth arguments
  445.  TO, SUBJECT, IN-REPLY-TO and CC specify if non-nil
  446.  the initial contents of those header fields.
  447.  These arguments should not have final newlines.
  448. The sixth argument REPLYBUFFER is a buffer whose contents
  449.  should be yanked if the user types C-c C-y."
  450.   (interactive "P")
  451.   (switch-to-buffer "*mail*")
  452.   (setq default-directory (expand-file-name "~/"))
  453.   (auto-save-mode auto-save-default)
  454.   (mail-mode)
  455.   (and (not noerase)
  456.        (or (not (buffer-modified-p))
  457.        (y-or-n-p "Unsent message being composed; erase it? "))
  458.        (progn (erase-buffer)
  459.           (mail-setup to subject in-reply-to cc replybuffer)
  460.           t)))
  461.  
  462. (defun mail-other-window (&optional noerase to subject in-reply-to cc replybuffer)
  463.   "Like `mail' command, but display mail buffer in another window."
  464.   (interactive "P")
  465.   (let ((pop-up-windows t))
  466.     (pop-to-buffer "*mail*"))
  467.   (mail noerase to subject in-reply-to cc replybuffer))
  468.  
  469. ;;; Do not add anything but external entries on this page.
  470.